| 1 | MODULE FTRAFO |
|---|
| 2 | |
|---|
| 3 | !! Implementation of the spectral transformation using reduced the Gaussian grid |
|---|
| 4 | |
|---|
| 5 | CONTAINS |
|---|
| 6 | |
|---|
| 7 | ! Implementierung der spektralen Transformationsmethode unter Verwendung |
|---|
| 8 | ! des reduzierten Gauss'schen Gitters |
|---|
| 9 | |
|---|
| 10 | |
|---|
| 11 | SUBROUTINE VDTOUV(XMN,XLAM,XPHI,GWSAVE,IFAX,P,MLAT,MNAUF,NI,NJ,NK) |
|---|
| 12 | |
|---|
| 13 | !! Berechnung der scale winds aus Vorticity und Divergenz |
|---|
| 14 | !! uebergibt man in XMN die Divergenz, so wird der divergente Anteil des |
|---|
| 15 | !! Windes (XPHI=Ud,XPHI=Vd) zurueckgegeben, uebergibt man die Vorticity, so |
|---|
| 16 | !! erhaelt man den rotationellen Wind (XLAM=Vrot,XPHI=-Urot). |
|---|
| 17 | !! Summiert man beide, erhaelt man den gesamten Scale wind |
|---|
| 18 | ! GWSAVE ist ein Hilfsfeld fuer die FFT |
|---|
| 19 | ! P enthaelt die assoziierten Legendrepolynome, H deren Ableitung |
|---|
| 20 | ! MLAT enthaelt die Anzahl der Gitterpunkte pro Breitenkreis |
|---|
| 21 | ! MNAUF gibt die spektrale Aufloesung an, |
|---|
| 22 | ! NI = Anzahl der Gauss'schen Gitterpunkte pro Flaeche |
|---|
| 23 | ! NJ = Anzahl der Gauss'schen Breiten, |
|---|
| 24 | ! NK = Anzahl der Niveaus |
|---|
| 25 | |
|---|
| 26 | USE PHTOGR |
|---|
| 27 | |
|---|
| 28 | IMPLICIT NONE |
|---|
| 29 | INTEGER J,N,NI,NJ,NK,MNAUF,GGIND(NJ/2) |
|---|
| 30 | INTEGER MLAT(NJ),IFAX(10,NJ) |
|---|
| 31 | REAL XMN(0:(MNAUF+1)*(MNAUF+2)-1,NK) |
|---|
| 32 | REAL P(0:(MNAUF+3)*(MNAUF+4)/2,NJ/2) |
|---|
| 33 | REAL H(0:(MNAUF+2)*(MNAUF+3)/2) |
|---|
| 34 | REAL XLAM(NI,NK),XPHI(NI,NK) |
|---|
| 35 | REAL GWSAVE(8*NJ+15,NJ/2) |
|---|
| 36 | REAL SCR,SCI,ACR,ACI,MUSCR,MUSCI,MUACR,MUACI |
|---|
| 37 | REAL RT,IT |
|---|
| 38 | |
|---|
| 39 | GGIND(1)=0 |
|---|
| 40 | DO 4 J = 2,NJ/2 |
|---|
| 41 | GGIND(J)=GGIND(J-1)+MLAT(J-1) |
|---|
| 42 | 4 CONTINUE |
|---|
| 43 | |
|---|
| 44 | !$OMP PARALLEL DO SCHEDULE(DYNAMIC) |
|---|
| 45 | DO 5 J = 1,NJ/2 |
|---|
| 46 | CALL VDUVSUB(J,XMN,XLAM,XPHI,GWSAVE,IFAX,P,GGIND(J),MLAT,MNAUF,NI,NJ,NK) |
|---|
| 47 | 5 CONTINUE |
|---|
| 48 | !$OMP END PARALLEL DO |
|---|
| 49 | |
|---|
| 50 | RETURN |
|---|
| 51 | |
|---|
| 52 | END SUBROUTINE VDTOUV |
|---|
| 53 | |
|---|
| 54 | SUBROUTINE VDUVSUB(J,XMN,XLAM,XPHI,GWSAVE,IFAX,P,GGIND,MLAT,MNAUF,NI,NJ,NK) |
|---|
| 55 | |
|---|
| 56 | USE PHTOGR |
|---|
| 57 | |
|---|
| 58 | IMPLICIT NONE |
|---|
| 59 | |
|---|
| 60 | INTEGER J,K,M,N,NI,NJ,NK,MNAUF,GGIND,LL,LLP,LLH,LLS,LLPS,LLHS |
|---|
| 61 | INTEGER MLAT(NJ),IFAX(10,NJ) |
|---|
| 62 | REAL UFOUC(0:MAXAUF),MUFOUC(0:MAXAUF) |
|---|
| 63 | REAL VFOUC(0:MAXAUF),MVFOUC(0:MAXAUF) |
|---|
| 64 | REAL XMN(0:(MNAUF+1)*(MNAUF+2)-1,NK) |
|---|
| 65 | REAL P(0:(MNAUF+3)*(MNAUF+4)/2,NJ/2) |
|---|
| 66 | REAL H(0:(MNAUF+2)*(MNAUF+3)/2) |
|---|
| 67 | REAL XLAM(NI,NK),XPHI(NI,NK) |
|---|
| 68 | REAL GWSAVE(8*NJ+15,NJ/2) |
|---|
| 69 | REAL ERAD,SCR,SCI,ACR,ACI,MUSCR,MUSCI,MUACR,MUACI |
|---|
| 70 | REAL FAC(0:MNAUF),RT,IT |
|---|
| 71 | |
|---|
| 72 | ERAD = 6367470.D0 |
|---|
| 73 | |
|---|
| 74 | FAC(0)=0.D0 |
|---|
| 75 | DO 12 N=1,MNAUF |
|---|
| 76 | FAC(N)=-ERAD/DBLE(N)/DBLE(N+1) |
|---|
| 77 | 12 CONTINUE |
|---|
| 78 | |
|---|
| 79 | CALL DPLGND(MNAUF,P(0,J),H) |
|---|
| 80 | DO 3 K = 1,NK |
|---|
| 81 | LL=0 |
|---|
| 82 | LLP=0 |
|---|
| 83 | LLH=0 |
|---|
| 84 | DO 2 M = 0,MNAUF |
|---|
| 85 | SCR=0.D0 |
|---|
| 86 | SCI=0.D0 |
|---|
| 87 | ACR=0.D0 |
|---|
| 88 | ACI=0.D0 |
|---|
| 89 | MUSCR=0.D0 |
|---|
| 90 | MUSCI=0.D0 |
|---|
| 91 | MUACR=0.D0 |
|---|
| 92 | MUACI=0.D0 |
|---|
| 93 | LLS=LL |
|---|
| 94 | LLPS=LLP |
|---|
| 95 | LLHS=LLH |
|---|
| 96 | IF (2*M+1 .LT. MLAT(J)) THEN |
|---|
| 97 | DO 1 N = M,MNAUF,2 |
|---|
| 98 | RT=XMN(2*LL,K)*FAC(N) |
|---|
| 99 | IT=XMN(2*LL+1,K)*FAC(N) |
|---|
| 100 | SCR =SCR+ RT*P(LLP,J) |
|---|
| 101 | SCI =SCI+ IT*P(LLP,J) |
|---|
| 102 | MUACR =MUACR+ RT*H(LLH) |
|---|
| 103 | MUACI =MUACI+ IT*H(LLH) |
|---|
| 104 | LL=LL+2 |
|---|
| 105 | LLP=LLP+2 |
|---|
| 106 | LLH=LLH+2 |
|---|
| 107 | 1 CONTINUE |
|---|
| 108 | LL=LLS+1 |
|---|
| 109 | LLP=LLPS+1 |
|---|
| 110 | LLH=LLHS+1 |
|---|
| 111 | DO 11 N = M+1,MNAUF,2 |
|---|
| 112 | RT=XMN(2*LL,K)*FAC(N) |
|---|
| 113 | IT=XMN(2*LL+1,K)*FAC(N) |
|---|
| 114 | ACR =ACR+ RT*P(LLP,J) |
|---|
| 115 | ACI =ACI+ IT*P(LLP,J) |
|---|
| 116 | MUSCR =MUSCR+ RT*H(LLH) |
|---|
| 117 | MUSCI =MUSCI+ IT*H(LLH) |
|---|
| 118 | LL=LL+2 |
|---|
| 119 | LLP=LLP+2 |
|---|
| 120 | LLH=LLH+2 |
|---|
| 121 | 11 CONTINUE |
|---|
| 122 | END IF |
|---|
| 123 | LL=LLS+(MNAUF-M+1) |
|---|
| 124 | LLP=LLPS+(MNAUF-M+3) |
|---|
| 125 | LLH=LLHS+(MNAUF-M+2) |
|---|
| 126 | |
|---|
| 127 | UFOUC(2*M)=-M*(SCI-ACI) |
|---|
| 128 | UFOUC(2*M+1)=M*(SCR-ACR) |
|---|
| 129 | VFOUC(2*M)=-M*(SCI+ACI) |
|---|
| 130 | VFOUC(2*M+1)=M*(SCR+ACR) |
|---|
| 131 | |
|---|
| 132 | MUFOUC(2*M)=-(MUSCR-MUACR) |
|---|
| 133 | MUFOUC(2*M+1)=-(MUSCI-MUACI) |
|---|
| 134 | MVFOUC(2*M)=-(MUSCR+MUACR) |
|---|
| 135 | MVFOUC(2*M+1)=-(MUSCI+MUACI) |
|---|
| 136 | 2 CONTINUE |
|---|
| 137 | |
|---|
| 138 | CALL RFOURTR(VFOUC,GWSAVE(:,J),IFAX(:,J),MNAUF,MLAT(J),1) |
|---|
| 139 | XLAM(GGIND+1:GGIND+MLAT(J),K)=VFOUC(0:MLAT(J)-1) |
|---|
| 140 | CALL RFOURTR(UFOUC,GWSAVE(:,J),IFAX(:,J),MNAUF,MLAT(J),1) |
|---|
| 141 | XLAM(NI-GGIND-MLAT(J)+1:NI-GGIND,K)=UFOUC(0:MLAT(J)-1) |
|---|
| 142 | |
|---|
| 143 | CALL RFOURTR(MVFOUC,GWSAVE(:,J),IFAX(:,J),MNAUF,MLAT(J),1) |
|---|
| 144 | XPHI(GGIND+1:GGIND+MLAT(J),K)=MVFOUC(0:MLAT(J)-1) |
|---|
| 145 | CALL RFOURTR(MUFOUC,GWSAVE(:,J),IFAX(:,J),MNAUF,MLAT(J),1) |
|---|
| 146 | XPHI(NI-GGIND-MLAT(J)+1:NI-GGIND,K)=MUFOUC(0:MLAT(J)-1) |
|---|
| 147 | |
|---|
| 148 | 3 CONTINUE |
|---|
| 149 | |
|---|
| 150 | RETURN |
|---|
| 151 | |
|---|
| 152 | END SUBROUTINE VDUVSUB |
|---|
| 153 | |
|---|
| 154 | |
|---|
| 155 | SUBROUTINE PHGRAD(XMN,XLAM,XPHI,GWSAVE,IFAX,P,H,MLAT,MNAUF,NI,NJ,NK) |
|---|
| 156 | |
|---|
| 157 | !! Berechnung des Gradienten eines Skalars aus dem Feld des |
|---|
| 158 | !! Skalars XMN im Phasenraum. Zurueckgegeben werden die Felder der |
|---|
| 159 | !! Komponenten des horizontalen Gradienten XLAM,XPHI auf dem Gauss'schen Gitter. |
|---|
| 160 | ! GWSAVE ist ein Hilfsfeld fuer die FFT |
|---|
| 161 | ! P enthaelt die assoziierten Legendrepolynome, H deren Ableitung |
|---|
| 162 | ! MLAT enthaelt die Anzahl der Gitterpunkte pro Breitenkreis |
|---|
| 163 | ! MNAUF gibt die spektrale Aufloesung an, |
|---|
| 164 | ! NI = Anzahl der Gauss'schen Gitterpunkte, |
|---|
| 165 | ! NJ = Anzahl der Gauss'schen Breiten, |
|---|
| 166 | ! NK = Anzahl der Niveaus |
|---|
| 167 | |
|---|
| 168 | USE PHTOGR |
|---|
| 169 | |
|---|
| 170 | IMPLICIT NONE |
|---|
| 171 | |
|---|
| 172 | INTEGER J,K,M,N,NI,NJ,NK,MNAUF,GGIND,LL,LLP,LLH,LLS,LLPS,LLHS |
|---|
| 173 | INTEGER MLAT(NJ),IFAX(10,NJ) |
|---|
| 174 | REAL UFOUC(0:MAXAUF),MUFOUC(0:MAXAUF) |
|---|
| 175 | REAL VFOUC(0:MAXAUF),MVFOUC(0:MAXAUF) |
|---|
| 176 | REAL XMN(0:(MNAUF+1)*(MNAUF+2)-1,NK) |
|---|
| 177 | REAL P(0:(MNAUF+3)*(MNAUF+4)/2,NJ/2) |
|---|
| 178 | REAL H(0:(MNAUF+2)*(MNAUF+3)/2) |
|---|
| 179 | REAL XLAM(NI,NK),XPHI(NI,NK) |
|---|
| 180 | REAL GWSAVE(8*NJ+15,NJ/2) |
|---|
| 181 | REAL ERAD |
|---|
| 182 | REAL SCR,SCI,ACR,ACI,MUSCR,MUSCI,MUACR,MUACI,RT,IT |
|---|
| 183 | |
|---|
| 184 | ERAD = 6367470.0 |
|---|
| 185 | |
|---|
| 186 | GGIND=0 |
|---|
| 187 | DO 4 J = 1,NJ/2 |
|---|
| 188 | CALL DPLGND(MNAUF,P(0,J),H) |
|---|
| 189 | DO 3 K = 1,NK |
|---|
| 190 | LL=0 |
|---|
| 191 | LLP=0 |
|---|
| 192 | LLH=0 |
|---|
| 193 | DO 2 M = 0,MNAUF |
|---|
| 194 | SCR=0.D0 |
|---|
| 195 | SCI=0.D0 |
|---|
| 196 | ACR=0.D0 |
|---|
| 197 | ACI=0.D0 |
|---|
| 198 | MUSCR=0.D0 |
|---|
| 199 | MUSCI=0.D0 |
|---|
| 200 | MUACR=0.D0 |
|---|
| 201 | MUACI=0.D0 |
|---|
| 202 | LLS=LL |
|---|
| 203 | LLPS=LLP |
|---|
| 204 | LLHS=LLH |
|---|
| 205 | IF (2*M+1 .LT. MLAT(J)) THEN |
|---|
| 206 | DO 1 N = M,MNAUF,2 |
|---|
| 207 | RT=XMN(2*LL,K) |
|---|
| 208 | IT=XMN(2*LL+1,K) |
|---|
| 209 | SCR =SCR+ RT*P(LLP,J) |
|---|
| 210 | SCI =SCI+ IT*P(LLP,J) |
|---|
| 211 | MUACR =MUACR+RT*H(LLH) |
|---|
| 212 | MUACI =MUACI+ IT*H(LLH) |
|---|
| 213 | LL=LL+2 |
|---|
| 214 | LLP=LLP+2 |
|---|
| 215 | LLH=LLH+2 |
|---|
| 216 | 1 CONTINUE |
|---|
| 217 | LL=LLS+1 |
|---|
| 218 | LLP=LLPS+1 |
|---|
| 219 | LLH=LLHS+1 |
|---|
| 220 | DO 11 N = M+1,MNAUF,2 |
|---|
| 221 | RT=XMN(2*LL,K) |
|---|
| 222 | IT=XMN(2*LL+1,K) |
|---|
| 223 | ACR =ACR+ RT*P(LLP,J) |
|---|
| 224 | ACI =ACI+ IT*P(LLP,J) |
|---|
| 225 | MUSCR =MUSCR+ RT*H(LLH) |
|---|
| 226 | MUSCI =MUSCI+ IT*H(LLH) |
|---|
| 227 | LL=LL+2 |
|---|
| 228 | LLP=LLP+2 |
|---|
| 229 | LLH=LLH+2 |
|---|
| 230 | 11 CONTINUE |
|---|
| 231 | END IF |
|---|
| 232 | LL=LLS+(MNAUF-M+1) |
|---|
| 233 | LLP=LLPS+(MNAUF-M+3) |
|---|
| 234 | LLH=LLHS+(MNAUF-M+2) |
|---|
| 235 | |
|---|
| 236 | UFOUC(2*M)=-M*(SCI-ACI)/ERAD |
|---|
| 237 | UFOUC(2*M+1)=M*(SCR-ACR)/ERAD |
|---|
| 238 | VFOUC(2*M)=-M*(SCI+ACI)/ERAD |
|---|
| 239 | VFOUC(2*M+1)=M*(SCR+ACR)/ERAD |
|---|
| 240 | |
|---|
| 241 | MUFOUC(2*M)=-(MUSCR-MUACR)/ERAD |
|---|
| 242 | MUFOUC(2*M+1)=-(MUSCI-MUACI)/ERAD |
|---|
| 243 | MVFOUC(2*M)=-(MUSCR+MUACR)/ERAD |
|---|
| 244 | MVFOUC(2*M+1)=-(MUSCI+MUACI)/ERAD |
|---|
| 245 | 2 CONTINUE |
|---|
| 246 | |
|---|
| 247 | CALL RFOURTR(VFOUC,GWSAVE(:,J),IFAX(:,J),MNAUF,MLAT(J),1) |
|---|
| 248 | XLAM(GGIND+1:GGIND+MLAT(J),K)=VFOUC(0:MLAT(J)-1) |
|---|
| 249 | CALL RFOURTR(UFOUC,GWSAVE(:,J),IFAX(:,J),MNAUF,MLAT(J),1) |
|---|
| 250 | XLAM(NI-GGIND-MLAT(J)+1:NI-GGIND,K)=UFOUC(0:MLAT(J)-1) |
|---|
| 251 | |
|---|
| 252 | CALL RFOURTR(MVFOUC,GWSAVE(:,J),IFAX(:,J),MNAUF,MLAT(J),1) |
|---|
| 253 | XPHI(GGIND+1:GGIND+MLAT(J),K)=MVFOUC(0:MLAT(J)-1) |
|---|
| 254 | CALL RFOURTR(MUFOUC,GWSAVE(:,J),IFAX(:,J),MNAUF,MLAT(J),1) |
|---|
| 255 | XPHI(NI-GGIND-MLAT(J)+1:NI-GGIND,K)=MUFOUC(0:MLAT(J)-1) |
|---|
| 256 | |
|---|
| 257 | 3 CONTINUE |
|---|
| 258 | GGIND=GGIND+MLAT(J) |
|---|
| 259 | 4 CONTINUE |
|---|
| 260 | |
|---|
| 261 | |
|---|
| 262 | RETURN |
|---|
| 263 | |
|---|
| 264 | END SUBROUTINE PHGRAD |
|---|
| 265 | |
|---|
| 266 | |
|---|
| 267 | SUBROUTINE PHGRACUT(XMN,XLAM,XPHI,GWSAVE,IFAX,P,H,MAUF,MNAUF,NI,NJ,MANF,NK) |
|---|
| 268 | |
|---|
| 269 | !! Berechnung des Gradienten eines Skalars aus dem Feld des |
|---|
| 270 | !! Skalars XMN im Phasenraum. Zurueckgegeben werden die Felder der |
|---|
| 271 | !! Komponenten des horizontalen Gradienten XLAM,XPHI auf dem Gauss'schen Gitter. |
|---|
| 272 | ! GWSAVE ist ein Hilfsfeld fuer die FFT |
|---|
| 273 | ! P enthaelt die assoziierten Legendrepolynome, H deren Ableitung |
|---|
| 274 | ! MLAT enthaelt die Anzahl der Gitterpunkte pro Breitenkreis |
|---|
| 275 | ! MNAUF gibt die spektrale Aufloesung an, |
|---|
| 276 | ! NI = Anzahl der Gauss'schen Gitterpunkte, |
|---|
| 277 | ! NJ = Anzahl der Gauss'schen Breiten, |
|---|
| 278 | ! NK = Anzahl der Niveaus |
|---|
| 279 | |
|---|
| 280 | USE PHTOGR |
|---|
| 281 | |
|---|
| 282 | IMPLICIT NONE |
|---|
| 283 | |
|---|
| 284 | INTEGER J,K,M,N,NI,NJ,NK,MNAUF,GGIND,LL,LLP,LLH,LLS,LLPS,LLHS |
|---|
| 285 | INTEGER MAUF,MANF,I,IFAX(10) |
|---|
| 286 | REAL UFOUC(0:MAXAUF),MUFOUC(0:MAXAUF) |
|---|
| 287 | REAL VFOUC(0:MAXAUF),MVFOUC(0:MAXAUF) |
|---|
| 288 | REAL XMN(0:(MNAUF+1)*(MNAUF+2)-1,NK) |
|---|
| 289 | REAL P(0:(MNAUF+3)*(MNAUF+4)/2,NJ) |
|---|
| 290 | REAL H(0:(MNAUF+2)*(MNAUF+3)/2) |
|---|
| 291 | REAL XLAM(NI,NJ,NK),XPHI(NI,NJ,NK) |
|---|
| 292 | REAL HLAM(MAXAUF,2),HPHI(MAXAUF,2) |
|---|
| 293 | REAL GWSAVE(4*MAUF+15) |
|---|
| 294 | REAL ERAD |
|---|
| 295 | REAL SCR,SCI,ACR,ACI,MUSCR,MUSCI,MUACR,MUACI,RT,IT |
|---|
| 296 | |
|---|
| 297 | ERAD = 6367470.0 |
|---|
| 298 | |
|---|
| 299 | GGIND=0 |
|---|
| 300 | DO 4 J = 1,NJ |
|---|
| 301 | CALL DPLGND(MNAUF,P(0,J),H) |
|---|
| 302 | DO 3 K = 1,NK |
|---|
| 303 | LL=0 |
|---|
| 304 | LLP=0 |
|---|
| 305 | LLH=0 |
|---|
| 306 | DO 2 M = 0,MNAUF |
|---|
| 307 | SCR=0.D0 |
|---|
| 308 | SCI=0.D0 |
|---|
| 309 | ACR=0.D0 |
|---|
| 310 | ACI=0.D0 |
|---|
| 311 | MUSCR=0.D0 |
|---|
| 312 | MUSCI=0.D0 |
|---|
| 313 | MUACR=0.D0 |
|---|
| 314 | MUACI=0.D0 |
|---|
| 315 | LLS=LL |
|---|
| 316 | LLPS=LLP |
|---|
| 317 | LLHS=LLH |
|---|
| 318 | IF (2*M+1 .LT. MAUF) THEN |
|---|
| 319 | DO 1 N = M,MNAUF,2 |
|---|
| 320 | RT=XMN(2*LL,K) |
|---|
| 321 | IT=XMN(2*LL+1,K) |
|---|
| 322 | SCR =SCR+ RT*P(LLP,J) |
|---|
| 323 | SCI =SCI+ IT*P(LLP,J) |
|---|
| 324 | MUACR =MUACR+RT*H(LLH) |
|---|
| 325 | MUACI =MUACI+ IT*H(LLH) |
|---|
| 326 | LL=LL+2 |
|---|
| 327 | LLP=LLP+2 |
|---|
| 328 | LLH=LLH+2 |
|---|
| 329 | 1 CONTINUE |
|---|
| 330 | LL=LLS+1 |
|---|
| 331 | LLP=LLPS+1 |
|---|
| 332 | LLH=LLHS+1 |
|---|
| 333 | DO 11 N = M+1,MNAUF,2 |
|---|
| 334 | RT=XMN(2*LL,K) |
|---|
| 335 | IT=XMN(2*LL+1,K) |
|---|
| 336 | ACR =ACR+ RT*P(LLP,J) |
|---|
| 337 | ACI =ACI+ IT*P(LLP,J) |
|---|
| 338 | MUSCR =MUSCR+ RT*H(LLH) |
|---|
| 339 | MUSCI =MUSCI+ IT*H(LLH) |
|---|
| 340 | LL=LL+2 |
|---|
| 341 | LLP=LLP+2 |
|---|
| 342 | LLH=LLH+2 |
|---|
| 343 | 11 CONTINUE |
|---|
| 344 | END IF |
|---|
| 345 | LL=LLS+(MNAUF-M+1) |
|---|
| 346 | LLP=LLPS+(MNAUF-M+3) |
|---|
| 347 | LLH=LLHS+(MNAUF-M+2) |
|---|
| 348 | |
|---|
| 349 | UFOUC(2*M)=-M*(SCI-ACI)/ERAD |
|---|
| 350 | UFOUC(2*M+1)=M*(SCR-ACR)/ERAD |
|---|
| 351 | VFOUC(2*M)=-M*(SCI+ACI)/ERAD |
|---|
| 352 | VFOUC(2*M+1)=M*(SCR+ACR)/ERAD |
|---|
| 353 | |
|---|
| 354 | MUFOUC(2*M)=-(MUSCR-MUACR)/ERAD |
|---|
| 355 | MUFOUC(2*M+1)=-(MUSCI-MUACI)/ERAD |
|---|
| 356 | MVFOUC(2*M)=-(MUSCR+MUACR)/ERAD |
|---|
| 357 | MVFOUC(2*M+1)=-(MUSCI+MUACI)/ERAD |
|---|
| 358 | 2 CONTINUE |
|---|
| 359 | |
|---|
| 360 | CALL RFOURTR(VFOUC,GWSAVE,IFAX,MNAUF,MAUF,1) |
|---|
| 361 | |
|---|
| 362 | CALL RFOURTR(MVFOUC,GWSAVE,IFAX,MNAUF,MAUF,1) |
|---|
| 363 | |
|---|
| 364 | DO 6 I=0,NI-1 |
|---|
| 365 | IF (MANF+I .LE. MAUF) THEN |
|---|
| 366 | XLAM(I+1,J,K)=VFOUC(MANF+I-1) |
|---|
| 367 | XPHI(I+1,J,K)=MVFOUC(MANF+I-1) |
|---|
| 368 | ELSE |
|---|
| 369 | XLAM(I+1,J,K)=VFOUC(MANF-MAUF+I-1) |
|---|
| 370 | XPHI(I+1,J,K)=MVFOUC(MANF-MAUF+I-1) |
|---|
| 371 | END IF |
|---|
| 372 | 6 CONTINUE |
|---|
| 373 | 3 CONTINUE |
|---|
| 374 | GGIND=GGIND+MAUF |
|---|
| 375 | 4 CONTINUE |
|---|
| 376 | |
|---|
| 377 | RETURN |
|---|
| 378 | |
|---|
| 379 | END SUBROUTINE PHGRACUT |
|---|
| 380 | |
|---|
| 381 | SUBROUTINE CONTGL(PS,DPSDL,DPSDM,DIV,U,V,BREITE,ETA,MLAT,A,B,NI,NJ,NK) |
|---|
| 382 | |
|---|
| 383 | !! Berechnung der Divergenz aus dem Windfeld (U,V) |
|---|
| 384 | !! im Phasenraum. Zurueckgegeben werden die Felder der |
|---|
| 385 | !! Komponenten des horizontalen Gradienten XLAM,XPHI auf dem Gauss'schen Gitter. |
|---|
| 386 | ! GWSAVE ist ein Hilfsfeld fuer die FFT |
|---|
| 387 | ! P enthaelt die assoziierten Legendrepolynome, H deren Ableitung |
|---|
| 388 | ! MLAT enthaelt die Anzahl der Gitterpunkte pro Breitenkreis |
|---|
| 389 | ! MNAUF gibt die spektrale Aufloesung an, |
|---|
| 390 | ! NI = Anzahl der Gauss'schen Gitterpunkte, |
|---|
| 391 | ! NJ = Anzahl der Gauss'schen Breiten, |
|---|
| 392 | ! NK = Anzahl der Niveaus |
|---|
| 393 | ! Beachte, dass das Windfeld eine um 1 erhoehte Aufloesung in mu-Richtung hat. |
|---|
| 394 | |
|---|
| 395 | IMPLICIT NONE |
|---|
| 396 | |
|---|
| 397 | INTEGER NI,NJ,NK,I,J,K,MLAT(NJ),L |
|---|
| 398 | |
|---|
| 399 | REAL A(NK+1),B(NK+1) |
|---|
| 400 | REAL PS(NI),DPSDL(NI),DPSDM(NI) |
|---|
| 401 | REAL DIV(NI,NK),U(NI,NK),V(NI,NK),ETA(NI,NK) |
|---|
| 402 | REAL BREITE(NJ) |
|---|
| 403 | |
|---|
| 404 | REAL DIVT1,DIVT2,POB,PUN,DPSDT,COSB |
|---|
| 405 | |
|---|
| 406 | L=0 |
|---|
| 407 | DO 4 J=1,NJ |
|---|
| 408 | COSB=(1.0-BREITE(J)*BREITE(J)) |
|---|
| 409 | DO 3 I=1,MLAT(J) |
|---|
| 410 | L=L+1 |
|---|
| 411 | DIVT1=0.0 |
|---|
| 412 | DIVT2=0.0 |
|---|
| 413 | DO 1 K=1,NK |
|---|
| 414 | POB=A(K)+B(K)*PS(L) |
|---|
| 415 | PUN=A(K+1)+B(K+1)*PS(L) |
|---|
| 416 | |
|---|
| 417 | DIVT1=DIVT1+DIV(L,K)*(PUN-POB) |
|---|
| 418 | IF (COSB .GT. 0.) THEN |
|---|
| 419 | DIVT2=DIVT2+(B(K+1)-B(K))*PS(L)* & |
|---|
| 420 | (U(L,K)*DPSDL(L)+V(L,K)*DPSDM(L))/COSB |
|---|
| 421 | END IF |
|---|
| 422 | |
|---|
| 423 | ETA(L,K)=-DIVT1-DIVT2 |
|---|
| 424 | 1 CONTINUE |
|---|
| 425 | |
|---|
| 426 | DPSDT=(-DIVT1-DIVT2)/PS(L) |
|---|
| 427 | |
|---|
| 428 | DO 2 K=1,NK |
|---|
| 429 | ETA(L,K)=ETA(L,K)-DPSDT*B(K+1)*PS(L) |
|---|
| 430 | 2 CONTINUE |
|---|
| 431 | PS(L)=DPSDT*PS(L) |
|---|
| 432 | 3 CONTINUE |
|---|
| 433 | 4 CONTINUE |
|---|
| 434 | |
|---|
| 435 | RETURN |
|---|
| 436 | |
|---|
| 437 | END SUBROUTINE CONTGL |
|---|
| 438 | |
|---|
| 439 | SUBROUTINE OMEGA(PS,DPSDL,DPSDM,DIV,U,V,BREITE,E,MLAT,A,B,NGI,NGJ,MKK) |
|---|
| 440 | |
|---|
| 441 | !! calculates $\omega$ in the hybrid ($\eta$-) coordinate system |
|---|
| 442 | |
|---|
| 443 | ! OMEGA berechnet omega im Hybridkoordinatensystem |
|---|
| 444 | ! PS ist der Bodendruck, |
|---|
| 445 | ! DPSDL,DPSDM sind die Komponenten des Gradienten des Logarithmus des |
|---|
| 446 | ! Bodendrucks |
|---|
| 447 | ! DIV,U,V sind die horizontale Divergenz und das horizontale Windfeld |
|---|
| 448 | ! BREITE ist das Feld der Gauss'schen Breiten |
|---|
| 449 | ! E ist omega, |
|---|
| 450 | |
|---|
| 451 | IMPLICIT NONE |
|---|
| 452 | |
|---|
| 453 | INTEGER I,J,K,L,NGI,NGJ,MKK,MLAT(NGJ) |
|---|
| 454 | |
|---|
| 455 | REAL PS(NGI),DPSDL(NGI),DPSDM(NGI),A(MKK+1),B(MKK+1) |
|---|
| 456 | REAL DIV(NGI,MKK),U(NGI,MKK),V(NGI,MKK),E(NGI,MKK) |
|---|
| 457 | REAL BREITE(NGJ) |
|---|
| 458 | |
|---|
| 459 | REAL DIVT1,DIVT2,POB,PUN,DP,X,Y,COSB |
|---|
| 460 | REAL DIVT3(MKK+2) |
|---|
| 461 | |
|---|
| 462 | L=0 |
|---|
| 463 | DO 4 J=1,NGJ |
|---|
| 464 | COSB=(1.0-BREITE(J)*BREITE(J)) |
|---|
| 465 | DO 3 I=1,MLAT(J) |
|---|
| 466 | L=L+1 |
|---|
| 467 | DIVT1=0.0 |
|---|
| 468 | DIVT2=0.0 |
|---|
| 469 | DIVT3(1)=0.0 |
|---|
| 470 | DO 1 K=1,MKK |
|---|
| 471 | POB=A(K)+B(K)*PS(L) |
|---|
| 472 | PUN=A(K+1)+B(K+1)*PS(L) |
|---|
| 473 | DP=PUN-POB |
|---|
| 474 | |
|---|
| 475 | Y=PS(L)*(U(L,K)*DPSDL(L)+V(L,K)*DPSDM(L))/COSB |
|---|
| 476 | IF (K .LT. 3) THEN |
|---|
| 477 | X=0.0 |
|---|
| 478 | ELSE |
|---|
| 479 | X=(B(K+1)-B(K))*Y |
|---|
| 480 | END IF |
|---|
| 481 | |
|---|
| 482 | DIVT1=DIVT1+DIV(L,K)*DP |
|---|
| 483 | DIVT2=DIVT2+X |
|---|
| 484 | |
|---|
| 485 | DIVT3(K+1)=-DIVT1-DIVT2 |
|---|
| 486 | |
|---|
| 487 | IF (K .GT. 1) THEN |
|---|
| 488 | E(L,K) = 0.5*(POB+PUN)/ & |
|---|
| 489 | DP*Y*((B(K+1)-B(K))+(A(K+1)*B(K)-A(K)*B(K+1))/DP*LOG(PUN/POB)) |
|---|
| 490 | ELSE |
|---|
| 491 | E(L,K) = 0.0 |
|---|
| 492 | END IF |
|---|
| 493 | |
|---|
| 494 | E(L,K) = E(L,K)+0.5*(DIVT3(K)+DIVT3(K+1)) |
|---|
| 495 | |
|---|
| 496 | 1 CONTINUE |
|---|
| 497 | 3 CONTINUE |
|---|
| 498 | 4 CONTINUE |
|---|
| 499 | |
|---|
| 500 | RETURN |
|---|
| 501 | |
|---|
| 502 | END SUBROUTINE OMEGA |
|---|
| 503 | |
|---|
| 504 | END MODULE FTRAFO |
|---|
