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 |
---|