GCC Code Coverage Report

Directory: ./
File: dyn3d_common/advzp.f
Date: 2022-01-11 19:19:34
Exec Total Coverage
Lines: 0 162 0.0%
Branches: 0 62 0.0%
Line Branch Exec Source
1 !
2 ! $Header$
3 !
4 ✗ SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ
5 . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
6
7 IMPLICIT NONE
8
9 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10 C C
11 C second-order moments (SOM) advection of tracer in Z direction C
12 C C
13 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
14 C C
15 C Source : Pascal Simon ( Meteo, CNRM ) C
16 C Adaptation : A.A. (LGGE) C
17 C Derniere Modif : 19/11/95 LAST C
18 C C
19 C sont les arguments d'entree pour le s-pg C
20 C C
21 C argument de sortie du s-pg C
22 C C
23 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
24 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
25 C
26 C Rem : Probleme aux poles il faut reecrire ce cas specifique
27 C Attention au sens de l'indexation
28 C
29
30 C
31 C parametres principaux du modele
32 C
33 include "dimensions.h"
34 include "paramet.h"
35 include "comgeom.h"
36 C
37 C Arguments :
38 C ----------
39 C dty : frequence fictive d'appel du transport
40 C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
41 c
42 INTEGER lon,lat,niv
43 INTEGER i,j,jv,k,kp,l,lp
44 INTEGER ntra
45 c PARAMETER (ntra = 1)
46 c
47 REAL dtz
48 REAL w ( iip1,jjp1,llm )
49 c
50 C moments: SM total mass in each grid box
51 C S0 mass of tracer in each grid box
52 C Si 1rst order moment in i direction
53 C
54 REAL SM(iip1,jjp1,llm)
55 + ,S0(iip1,jjp1,llm,ntra)
56 REAL SSX(iip1,jjp1,llm,ntra)
57 + ,SY(iip1,jjp1,llm,ntra)
58 + ,SZ(iip1,jjp1,llm,ntra)
59 + ,SSXX(iip1,jjp1,llm,ntra)
60 + ,SSXY(iip1,jjp1,llm,ntra)
61 + ,SSXZ(iip1,jjp1,llm,ntra)
62 + ,SYY(iip1,jjp1,llm,ntra)
63 + ,SYZ(iip1,jjp1,llm,ntra)
64 + ,SZZ(iip1,jjp1,llm,ntra)
65 C
66 C Local :
67 C -------
68 C
69 C mass fluxes across the boundaries (UGRI,VGRI,WGRI)
70 C mass fluxes in kg
71 C declaration :
72 C
73 REAL WGRI(iip1,jjp1,0:llm)
74
75 C Rem : UGRI et VGRI ne sont pas utilises dans
76 C cette subroutine ( advection en z uniquement )
77 C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
78 C attention a celui de WGRI
79 C
80 C the moments F are similarly defined and used as temporary
81 C storage for portions of the grid boxes in transit
82 C
83 C the moments Fij are used as temporary storage for
84 C portions of the grid boxes in transit at the current level
85 C
86 C work arrays
87 C
88 C
89 ✗ REAL F0(iim,llm,ntra),FM(iim,llm)
90 ✗ REAL FX(iim,llm,ntra),FY(iim,llm,ntra)
91 ✗ REAL FZ(iim,llm,ntra)
92 ✗ REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra)
93 ✗ REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra)
94 ✗ REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra)
95 REAL S00(ntra)
96 REAL SM0 ! Just temporal variable
97 C
98 C work arrays
99 C
100 REAL ALF(iim),ALF1(iim)
101 REAL ALFQ(iim),ALF1Q(iim)
102 REAL ALF2(iim),ALF3(iim)
103 REAL ALF4(iim)
104 REAL TEMPTM ! Just temporal variable
105 REAL SLPMAX,S1MAX,S1NEW,S2NEW
106 c
107 REAL sqi,sqf
108 LOGICAL LIMIT
109
110 lon = iim ! rem : Il est possible qu'un pbl. arrive ici
111 lat = jjp1 ! a cause des dim. differentes entre les
112 niv = llm ! tab. S et VGRI
113
114 c-----------------------------------------------------------------
115 C *** Test : diag de la qtite totale de traceur dans
116 C l'atmosphere avant l'advection en Y
117 c
118 ✗ sqi = 0.
119 ✗ sqf = 0.
120 c
121 ✗ DO l = 1,llm
122 ✗ DO j = 1,jjp1
123 ✗ DO i = 1,iim
124 ✗ sqi = sqi + S0(i,j,l,ntra)
125 END DO
126 END DO
127 END DO
128 ✗ PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------'
129 ✗ PRINT*,'sqi=',sqi
130
131 c-----------------------------------------------------------------
132 C Interface : adaptation nouveau modele
133 C -------------------------------------
134 C
135 C Conversion des flux de masses en kg
136
137 ✗ DO 500 l = 1,llm
138 ✗ DO 500 j = 1,jjp1
139 ✗ DO 500 i = 1,iip1
140 ✗ wgri (i,j,llm+1-l) = w (i,j,l)
141 ✗ 500 CONTINUE
142 ✗ do j=1,jjp1
143 ✗ do i=1,iip1
144 ✗ wgri(i,j,0)=0.
145 enddo
146 enddo
147 c
148 cAA rem : Je ne suis pas sur du signe
149 cAA Je ne suis pas sur pour le 0:llm
150 c
151 c-----------------------------------------------------------------
152 C---------------------- START HERE -------------------------------
153 C
154 C boucle sur les latitudes
155 C
156 ✗ DO 1 K=1,LAT
157 C
158 C place limits on appropriate moments before transport
159 C (if flux-limiting is to be applied)
160 C
161 ✗ IF(.NOT.LIMIT) GO TO 101
162 C
163 ✗ DO 10 JV=1,NTRA
164 ✗ DO 10 L=1,NIV
165 ✗ DO 100 I=1,LON
166 ✗ IF(S0(I,K,L,JV).GT.0.) THEN
167 SLPMAX=S0(I,K,L,JV)
168 ✗ S1MAX =1.5*SLPMAX
169 ✗ S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV)))
170 S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
171 ✗ + AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) )
172 ✗ SZ (I,K,L,JV)=S1NEW
173 ✗ SZZ(I,K,L,JV)=S2NEW
174 ✗ SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV)))
175 ✗ SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
176 ELSE
177 ✗ SZ (I,K,L,JV)=0.
178 ✗ SZZ(I,K,L,JV)=0.
179 ✗ SSXZ(I,K,L,JV)=0.
180 ✗ SYZ(I,K,L,JV)=0.
181 ENDIF
182 ✗ 100 CONTINUE
183 ✗ 10 CONTINUE
184 C
185 101 CONTINUE
186 C
187 C boucle sur les niveaux intercouches de 1 a NIV-1
188 C (flux nul au sommet L=0 et a la base L=NIV)
189 C
190 C calculate flux and moments between adjacent boxes
191 C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
192 C 1- create temporary moments/masses for partial boxes in transit
193 C 2- reajusts moments remaining in the box
194 C
195 ✗ DO 11 L=1,NIV-1
196 ✗ LP=L+1
197 C
198 ✗ DO 110 I=1,LON
199 C
200 ✗ IF(WGRI(I,K,L).LT.0.) THEN
201 ✗ FM(I,L)=-WGRI(I,K,L)*DTZ
202 ✗ ALF(I)=FM(I,L)/SM(I,K,LP)
203 ✗ SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
204 ELSE
205 ✗ FM(I,L)=WGRI(I,K,L)*DTZ
206 ✗ ALF(I)=FM(I,L)/SM(I,K,L)
207 ✗ SM(I,K,L)=SM(I,K,L)-FM(I,L)
208 ENDIF
209 C
210 ✗ ALFQ (I)=ALF(I)*ALF(I)
211 ✗ ALF1 (I)=1.-ALF(I)
212 ✗ ALF1Q(I)=ALF1(I)*ALF1(I)
213 ✗ ALF2 (I)=ALF1(I)-ALF(I)
214 ✗ ALF3 (I)=ALF(I)*ALFQ(I)
215 ✗ ALF4 (I)=ALF1(I)*ALF1Q(I)
216 C
217 ✗ 110 CONTINUE
218 C
219 ✗ DO 111 JV=1,NTRA
220 ✗ DO 1110 I=1,LON
221 C
222 ✗ IF(WGRI(I,K,L).LT.0.) THEN
223 C
224 F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)*
225 ✗ + ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) )
226 ✗ FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV))
227 ✗ FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV)
228 ✗ FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV)
229 ✗ FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV)
230 ✗ FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV))
231 ✗ FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV))
232 ✗ FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV)
233 ✗ FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV)
234 ✗ FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV)
235 C
236 ✗ S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV)
237 SZ (I,K,LP,JV)=ALF1Q(I)
238 ✗ + *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV))
239 ✗ SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV)
240 ✗ SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV)
241 ✗ SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV)
242 ✗ SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV)
243 ✗ SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV)
244 ✗ SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV)
245 ✗ SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV)
246 ✗ SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV)
247 C
248 ELSE
249 C
250 F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV)
251 ✗ + +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) )
252 ✗ FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV))
253 ✗ FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV)
254 ✗ FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV)
255 ✗ FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV)
256 ✗ FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV))
257 ✗ FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV))
258 ✗ FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV)
259 ✗ FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV)
260 ✗ FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV)
261 C
262 ✗ S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV)
263 ✗ SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV))
264 ✗ SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV)
265 ✗ SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV)
266 ✗ SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV)
267 ✗ SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV)
268 ✗ SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV)
269 ✗ SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV)
270 ✗ SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV)
271 ✗ SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV)
272 C
273 ENDIF
274 C
275 ✗ 1110 CONTINUE
276 ✗ 111 CONTINUE
277 C
278 ✗ 11 CONTINUE
279 C
280 C puts the temporary moments Fi into appropriate neighboring boxes
281 C
282 ✗ DO 12 L=1,NIV-1
283 ✗ LP=L+1
284 C
285 ✗ DO 120 I=1,LON
286 C
287 ✗ IF(WGRI(I,K,L).LT.0.) THEN
288 ✗ SM(I,K,L)=SM(I,K,L)+FM(I,L)
289 ✗ ALF(I)=FM(I,L)/SM(I,K,L)
290 ELSE
291 ✗ SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
292 ✗ ALF(I)=FM(I,L)/SM(I,K,LP)
293 ENDIF
294 C
295 ✗ ALF1(I)=1.-ALF(I)
296 ✗ ALFQ(I)=ALF(I)*ALF(I)
297 ✗ ALF1Q(I)=ALF1(I)*ALF1(I)
298 ✗ ALF2(I)=ALF(I)*ALF1(I)
299 ✗ ALF3(I)=ALF1(I)-ALF(I)
300 C
301 ✗ 120 CONTINUE
302 C
303 ✗ DO 121 JV=1,NTRA
304 ✗ DO 1210 I=1,LON
305 C
306 ✗ IF(WGRI(I,K,L).LT.0.) THEN
307 C
308 ✗ TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
309 ✗ S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
310 SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV)
311 ✗ + +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM )
312 SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV)
313 ✗ + +3.*TEMPTM
314 SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV)
315 ✗ + +3.*(ALF1(I)*FX (I,L,JV)-ALF (I)*SSX (I,K,L,JV))
316 SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV)
317 ✗ + +3.*(ALF1(I)*FY (I,L,JV)-ALF (I)*SY (I,K,L,JV))
318 ✗ SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV)
319 ✗ SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV)
320 ✗ SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV)
321 ✗ SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV)
322 ✗ SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV)
323 C
324 ELSE
325 C
326 ✗ TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
327 ✗ S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
328 SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV)
329 ✗ + +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM )
330 SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV)
331 ✗ + +3.*TEMPTM
332 SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV)
333 ✗ + +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV))
334 SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV)
335 ✗ + +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV))
336 ✗ SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV)
337 ✗ SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV)
338 ✗ SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV)
339 ✗ SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV)
340 ✗ SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV)
341 C
342 ENDIF
343 C
344 ✗ 1210 CONTINUE
345 ✗ 121 CONTINUE
346 C
347 ✗ 12 CONTINUE
348 C
349 C fin de la boucle principale sur les latitudes
350 C
351 ✗ 1 CONTINUE
352 C
353 ✗ DO l = 1,llm
354 ✗ DO j = 1,jjp1
355 ✗ SM(iip1,j,l) = SM(1,j,l)
356 ✗ S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
357 ✗ SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
358 ✗ SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
359 ✗ SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
360 ENDDO
361 ENDDO
362 c C-------------------------------------------------------------
363 C *** Test : diag de la qqtite totale de tarceur
364 C dans l'atmosphere avant l'advection en z
365 ✗ DO l = 1,llm
366 ✗ DO j = 1,jjp1
367 ✗ DO i = 1,iim
368 ✗ sqf = sqf + S0(i,j,l,ntra)
369 ENDDO
370 ENDDO
371 ENDDO
372 ✗ PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
373 ✗ PRINT*,'sqf=', sqf
374
375 ✗ RETURN
376 END
377