GCC Code Coverage Report


Directory: ./
File: dyn3d_common/advyp.f
Date: 2022-01-11 19:19:34
Exec Total Coverage
Lines: 0 300 0.0%
Branches: 0 132 0.0%

Line Branch Exec Source
1 !
2 ! $Header$
3 !
4 SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ
5 . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
6 IMPLICIT NONE
7 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8 C C
9 C second-order moments (SOM) advection of tracer in Y direction C
10 C C
11 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
12 C C
13 C Source : Pascal Simon ( Meteo, CNRM ) C
14 C Adaptation : A.A. (LGGE) C
15 C Derniere Modif : 19/10/95 LAST
16 C C
17 C sont les arguments d'entree pour le s-pg C
18 C C
19 C argument de sortie du s-pg C
20 C C
21 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
22 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
23 C
24 C Rem : Probleme aux poles il faut reecrire ce cas specifique
25 C Attention au sens de l'indexation
26 C
27 C parametres principaux du modele
28 C
29 C
30 include "dimensions.h"
31 include "paramet.h"
32 include "comgeom.h"
33
34 C Arguments :
35 C ----------
36 C dty : frequence fictive d'appel du transport
37 C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
38
39 INTEGER lon,lat,niv
40 INTEGER i,j,jv,k,kp,l
41 INTEGER ntra
42 C PARAMETER (ntra = 1)
43
44 REAL dty
45 REAL pbarv ( iip1,jjm, llm )
46
47 C moments: SM total mass in each grid box
48 C S0 mass of tracer in each grid box
49 C Si 1rst order moment in i direction
50 C
51 REAL SM(iip1,jjp1,llm)
52 + ,S0(iip1,jjp1,llm,ntra)
53 REAL SSX(iip1,jjp1,llm,ntra)
54 + ,SY(iip1,jjp1,llm,ntra)
55 + ,SZ(iip1,jjp1,llm,ntra)
56 + ,SSXX(iip1,jjp1,llm,ntra)
57 + ,SSXY(iip1,jjp1,llm,ntra)
58 + ,SSXZ(iip1,jjp1,llm,ntra)
59 + ,SYY(iip1,jjp1,llm,ntra)
60 + ,SYZ(iip1,jjp1,llm,ntra)
61 + ,SZZ(iip1,jjp1,llm,ntra)
62 C
63 C Local :
64 C -------
65
66 C mass fluxes across the boundaries (UGRI,VGRI,WGRI)
67 C mass fluxes in kg
68 C declaration :
69
70 REAL VGRI(iip1,0:jjp1,llm)
71
72 C Rem : UGRI et WGRI ne sont pas utilises dans
73 C cette subroutine ( advection en y uniquement )
74 C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
75 C
76 C the moments F are similarly defined and used as temporary
77 C storage for portions of the grid boxes in transit
78 C
79 C the moments Fij are used as temporary storage for
80 C portions of the grid boxes in transit at the current level
81 C
82 C work arrays
83 C
84 C
85 REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
86 REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
87 REAL FZ(iim,jjm,ntra)
88 REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra)
89 REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra)
90 REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra)
91 REAL S00(ntra)
92 REAL SM0 ! Just temporal variable
93 C
94 C work arrays
95 C
96 REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
97 REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
98 REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1)
99 REAL ALF4(iim,0:jjp1)
100 REAL TEMPTM ! Just temporal variable
101 REAL SLPMAX,S1MAX,S1NEW,S2NEW
102 c
103 C Special pour poles
104 c
105 REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
106 REAL sns0(ntra),snsz(ntra),snsm
107 REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
108 REAL cx1(llm,ntra), cxLAT(llm,ntra)
109 REAL cy1(llm,ntra), cyLAT(llm,ntra)
110 REAL z1(iim), zcos(iim), zsin(iim)
111 REAL SSUM
112 EXTERNAL SSUM
113 C
114 REAL sqi,sqf
115 LOGICAL LIMIT
116
117 lon = iim ! rem : Il est possible qu'un pbl. arrive ici
118 lat = jjp1 ! a cause des dim. differentes entre les
119 niv = llm ! tab. S et VGRI
120
121 c-----------------------------------------------------------------
122 C initialisations
123
124 sbms = 0.
125 sfms = 0.
126 sfzs = 0.
127 sbmn = 0.
128 sfmn = 0.
129 sfzn = 0.
130
131 c-----------------------------------------------------------------
132 C *** Test : diag de la qtite totale de traceur dans
133 C l'atmosphere avant l'advection en Y
134 c
135 sqi = 0.
136 sqf = 0.
137
138 DO l = 1,llm
139 DO j = 1,jjp1
140 DO i = 1,iim
141 sqi = sqi + S0(i,j,l,ntra)
142 END DO
143 END DO
144 END DO
145 PRINT*,'---------- DIAG DANS ADVY - ENTREE --------'
146 PRINT*,'sqi=',sqi
147
148 c-----------------------------------------------------------------
149 C Interface : adaptation nouveau modele
150 C -------------------------------------
151 C
152 C Conversion des flux de masses en kg
153 C-AA 20/10/94 le signe -1 est necessaire car indexation opposee
154
155 DO 500 l = 1,llm
156 DO 500 j = 1,jjm
157 DO 500 i = 1,iip1
158 vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l)
159 500 CONTINUE
160
161 CAA Initialisation de flux fictifs aux bords sup. des boites pol.
162
163 DO l = 1,llm
164 DO i = 1,iip1
165 vgri(i,0,l) = 0.
166 vgri(i,jjp1,l) = 0.
167 ENDDO
168 ENDDO
169 c
170 c----------------- START HERE -----------------------
171 C boucle sur les niveaux
172 C
173 DO 1 L=1,NIV
174 C
175 C place limits on appropriate moments before transport
176 C (if flux-limiting is to be applied)
177 C
178 IF(.NOT.LIMIT) GO TO 11
179 C
180 DO 10 JV=1,NTRA
181 DO 10 K=1,LAT
182 DO 100 I=1,LON
183 IF(S0(I,K,L,JV).GT.0.) THEN
184 SLPMAX=AMAX1(S0(I,K,L,JV),0.)
185 S1MAX=1.5*SLPMAX
186 S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV)))
187 S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
188 + AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) )
189 SY (I,K,L,JV)=S1NEW
190 SYY(I,K,L,JV)=S2NEW
191 SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV)))
192 SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
193 ELSE
194 SY (I,K,L,JV)=0.
195 SYY(I,K,L,JV)=0.
196 SSXY(I,K,L,JV)=0.
197 SYZ(I,K,L,JV)=0.
198 ENDIF
199 100 CONTINUE
200 10 CONTINUE
201 C
202 11 CONTINUE
203 C
204 C le flux a travers le pole Nord est traite separement
205 C
206 SM0=0.
207 DO 20 JV=1,NTRA
208 S00(JV)=0.
209 20 CONTINUE
210 C
211 DO 21 I=1,LON
212 C
213 IF(VGRI(I,0,L).LE.0.) THEN
214 FM(I,0)=-VGRI(I,0,L)*DTY
215 ALF(I,0)=FM(I,0)/SM(I,1,L)
216 SM(I,1,L)=SM(I,1,L)-FM(I,0)
217 SM0=SM0+FM(I,0)
218 ENDIF
219 C
220 ALFQ(I,0)=ALF(I,0)*ALF(I,0)
221 ALF1(I,0)=1.-ALF(I,0)
222 ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
223 ALF2(I,0)=ALF1(I,0)-ALF(I,0)
224 ALF3(I,0)=ALF(I,0)*ALFQ(I,0)
225 ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0)
226 C
227 21 CONTINUE
228 c print*,'ADVYP 21'
229 C
230 DO 22 JV=1,NTRA
231 DO 220 I=1,LON
232 C
233 IF(VGRI(I,0,L).LE.0.) THEN
234 C
235 F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)*
236 + ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) )
237 C
238 S00(JV)=S00(JV)+F0(I,0,JV)
239 S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
240 SY (I,1,L,JV)=ALF1Q(I,0)*
241 + (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV))
242 SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV)
243 SSX (I,1,L,JV)=ALF1 (I,0)*
244 + (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) )
245 SZ (I,1,L,JV)=ALF1 (I,0)*
246 + (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) )
247 SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV)
248 SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV)
249 SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV)
250 SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV)
251 SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV)
252 C
253 ENDIF
254 C
255 220 CONTINUE
256 22 CONTINUE
257 C
258 DO 23 I=1,LON
259 IF(VGRI(I,0,L).GT.0.) THEN
260 FM(I,0)=VGRI(I,0,L)*DTY
261 ALF(I,0)=FM(I,0)/SM0
262 ENDIF
263 23 CONTINUE
264 C
265 DO 24 JV=1,NTRA
266 DO 240 I=1,LON
267 IF(VGRI(I,0,L).GT.0.) THEN
268 F0(I,0,JV)=ALF(I,0)*S00(JV)
269 ENDIF
270 240 CONTINUE
271 24 CONTINUE
272 C
273 C puts the temporary moments Fi into appropriate neighboring boxes
274 C
275 c print*,'av ADVYP 25'
276 DO 25 I=1,LON
277 C
278 IF(VGRI(I,0,L).GT.0.) THEN
279 SM(I,1,L)=SM(I,1,L)+FM(I,0)
280 ALF(I,0)=FM(I,0)/SM(I,1,L)
281 ENDIF
282 C
283 ALFQ(I,0)=ALF(I,0)*ALF(I,0)
284 ALF1(I,0)=1.-ALF(I,0)
285 ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
286 ALF2(I,0)=ALF1(I,0)-ALF(I,0)
287 ALF3(I,0)=ALF1(I,0)*ALF(I,0)
288 C
289 25 CONTINUE
290 c print*,'av ADVYP 25'
291 C
292 DO 26 JV=1,NTRA
293 DO 260 I=1,LON
294 C
295 IF(VGRI(I,0,L).GT.0.) THEN
296 C
297 TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
298 S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
299 SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV)
300 + +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM )
301 SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM
302 SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV)
303 SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV)
304 C
305 ENDIF
306 C
307 260 CONTINUE
308 26 CONTINUE
309 C
310 C calculate flux and moments between adjacent boxes
311 C 1- create temporary moments/masses for partial boxes in transit
312 C 2- reajusts moments remaining in the box
313 C
314 C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
315 C
316 c print*,'av ADVYP 30'
317 DO 30 K=1,LAT-1
318 KP=K+1
319 DO 300 I=1,LON
320 C
321 IF(VGRI(I,K,L).LT.0.) THEN
322 FM(I,K)=-VGRI(I,K,L)*DTY
323 ALF(I,K)=FM(I,K)/SM(I,KP,L)
324 SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
325 ELSE
326 FM(I,K)=VGRI(I,K,L)*DTY
327 ALF(I,K)=FM(I,K)/SM(I,K,L)
328 SM(I,K,L)=SM(I,K,L)-FM(I,K)
329 ENDIF
330 C
331 ALFQ(I,K)=ALF(I,K)*ALF(I,K)
332 ALF1(I,K)=1.-ALF(I,K)
333 ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
334 ALF2(I,K)=ALF1(I,K)-ALF(I,K)
335 ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
336 ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
337 C
338 300 CONTINUE
339 30 CONTINUE
340 c print*,'ap ADVYP 30'
341 C
342 DO 31 JV=1,NTRA
343 DO 31 K=1,LAT-1
344 KP=K+1
345 DO 310 I=1,LON
346 C
347 IF(VGRI(I,K,L).LT.0.) THEN
348 C
349 F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)*
350 + ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) )
351 FY (I,K,JV)=ALFQ(I,K)*
352 + (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV))
353 FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV)
354 FX (I,K,JV)=ALF (I,K)*
355 + (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV))
356 FZ (I,K,JV)=ALF (I,K)*
357 + (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV))
358 FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV)
359 FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV)
360 FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV)
361 FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV)
362 FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV)
363 C
364 S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
365 SY (I,KP,L,JV)=ALF1Q(I,K)*
366 + (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV))
367 SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV)
368 SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV)
369 SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV)
370 SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV)
371 SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV)
372 SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV)
373 SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV)
374 SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV)
375 C
376 ELSE
377 C
378 F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
379 + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
380 FY (I,K,JV)=ALFQ(I,K)*
381 + (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV))
382 FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV)
383 FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV))
384 FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV))
385 FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV)
386 FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV)
387 FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV)
388 FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV)
389 FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV)
390 C
391 S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
392 SY (I,K,L,JV)=ALF1Q(I,K)*
393 + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
394 SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV)
395 SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV)
396 SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV)
397 SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV)
398 SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV)
399 SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV)
400 SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
401 SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
402 C
403 ENDIF
404 C
405 310 CONTINUE
406 31 CONTINUE
407 c print*,'ap ADVYP 31'
408 C
409 C puts the temporary moments Fi into appropriate neighboring boxes
410 C
411 DO 32 K=1,LAT-1
412 KP=K+1
413 DO 320 I=1,LON
414 C
415 IF(VGRI(I,K,L).LT.0.) THEN
416 SM(I,K,L)=SM(I,K,L)+FM(I,K)
417 ALF(I,K)=FM(I,K)/SM(I,K,L)
418 ELSE
419 SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
420 ALF(I,K)=FM(I,K)/SM(I,KP,L)
421 ENDIF
422 C
423 ALFQ(I,K)=ALF(I,K)*ALF(I,K)
424 ALF1(I,K)=1.-ALF(I,K)
425 ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
426 ALF2(I,K)=ALF1(I,K)-ALF(I,K)
427 ALF3(I,K)=ALF1(I,K)*ALF(I,K)
428 C
429 320 CONTINUE
430 32 CONTINUE
431 c print*,'ap ADVYP 32'
432 C
433 DO 33 JV=1,NTRA
434 DO 33 K=1,LAT-1
435 KP=K+1
436 DO 330 I=1,LON
437 C
438 IF(VGRI(I,K,L).LT.0.) THEN
439 C
440 TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
441 S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
442 SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV)
443 + +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM )
444 SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV)
445 + +3.*TEMPTM
446 SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV)
447 + +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV))
448 SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV)
449 + +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV))
450 SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV)
451 SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV)
452 SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV)
453 SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV)
454 SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV)
455 C
456 ELSE
457 C
458 TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
459 S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
460 SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV)
461 + +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM )
462 SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV)
463 + +3.*TEMPTM
464 SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV)
465 + +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV))
466 SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV)
467 + +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV))
468 SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV)
469 SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV)
470 SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV)
471 SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV)
472 SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV)
473 C
474 ENDIF
475 C
476 330 CONTINUE
477 33 CONTINUE
478 c print*,'ap ADVYP 33'
479 C
480 C traitement special pour le pole Sud (idem pole Nord)
481 C
482 K=LAT
483 C
484 SM0=0.
485 DO 40 JV=1,NTRA
486 S00(JV)=0.
487 40 CONTINUE
488 C
489 DO 41 I=1,LON
490 C
491 IF(VGRI(I,K,L).GE.0.) THEN
492 FM(I,K)=VGRI(I,K,L)*DTY
493 ALF(I,K)=FM(I,K)/SM(I,K,L)
494 SM(I,K,L)=SM(I,K,L)-FM(I,K)
495 SM0=SM0+FM(I,K)
496 ENDIF
497 C
498 ALFQ(I,K)=ALF(I,K)*ALF(I,K)
499 ALF1(I,K)=1.-ALF(I,K)
500 ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
501 ALF2(I,K)=ALF1(I,K)-ALF(I,K)
502 ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
503 ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
504 C
505 41 CONTINUE
506 c print*,'ap ADVYP 41'
507 C
508 DO 42 JV=1,NTRA
509 DO 420 I=1,LON
510 C
511 IF(VGRI(I,K,L).GE.0.) THEN
512 F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
513 + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
514 S00(JV)=S00(JV)+F0(I,K,JV)
515 C
516 S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
517 SY (I,K,L,JV)=ALF1Q(I,K)*
518 + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
519 SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV)
520 SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV))
521 SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV))
522 SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV)
523 SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV)
524 SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV)
525 SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
526 SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
527 ENDIF
528 C
529 420 CONTINUE
530 42 CONTINUE
531 c print*,'ap ADVYP 42'
532 C
533 DO 43 I=1,LON
534 IF(VGRI(I,K,L).LT.0.) THEN
535 FM(I,K)=-VGRI(I,K,L)*DTY
536 ALF(I,K)=FM(I,K)/SM0
537 ENDIF
538 43 CONTINUE
539 c print*,'ap ADVYP 43'
540 C
541 DO 44 JV=1,NTRA
542 DO 440 I=1,LON
543 IF(VGRI(I,K,L).LT.0.) THEN
544 F0(I,K,JV)=ALF(I,K)*S00(JV)
545 ENDIF
546 440 CONTINUE
547 44 CONTINUE
548 C
549 C puts the temporary moments Fi into appropriate neighboring boxes
550 C
551 DO 45 I=1,LON
552 C
553 IF(VGRI(I,K,L).LT.0.) THEN
554 SM(I,K,L)=SM(I,K,L)+FM(I,K)
555 ALF(I,K)=FM(I,K)/SM(I,K,L)
556 ENDIF
557 C
558 ALFQ(I,K)=ALF(I,K)*ALF(I,K)
559 ALF1(I,K)=1.-ALF(I,K)
560 ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
561 ALF2(I,K)=ALF1(I,K)-ALF(I,K)
562 ALF3(I,K)=ALF1(I,K)*ALF(I,K)
563 C
564 45 CONTINUE
565 c print*,'ap ADVYP 45'
566 C
567 DO 46 JV=1,NTRA
568 DO 460 I=1,LON
569 C
570 IF(VGRI(I,K,L).LT.0.) THEN
571 C
572 TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
573 S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
574 SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV)
575 + +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM )
576 SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM
577 SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV)
578 SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV)
579 C
580 ENDIF
581 C
582 460 CONTINUE
583 46 CONTINUE
584 c print*,'ap ADVYP 46'
585 C
586 1 CONTINUE
587
588 c--------------------------------------------------
589 C bouclage cyclique horizontal .
590
591 DO l = 1,llm
592 DO jv = 1,ntra
593 DO j = 1,jjp1
594 SM(iip1,j,l) = SM(1,j,l)
595 S0(iip1,j,l,jv) = S0(1,j,l,jv)
596 SSX(iip1,j,l,jv) = SSX(1,j,l,jv)
597 SY(iip1,j,l,jv) = SY(1,j,l,jv)
598 SZ(iip1,j,l,jv) = SZ(1,j,l,jv)
599 END DO
600 END DO
601 END DO
602
603 c -------------------------------------------------------------------
604 C *** Test negativite:
605
606 c DO jv = 1,ntra
607 c DO l = 1,llm
608 c DO j = 1,jjp1
609 c DO i = 1,iip1
610 c IF (s0( i,j,l,jv ).lt.0.) THEN
611 c PRINT*, '------ S0 < 0 en FIN ADVYP ---'
612 c PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv)
613 cc STOP
614 c ENDIF
615 c ENDDO
616 c ENDDO
617 c ENDDO
618 c ENDDO
619
620
621 c -------------------------------------------------------------------
622 C *** Test : diag de la qtite totale de traceur dans
623 C l'atmosphere avant l'advection en Y
624
625 DO l = 1,llm
626 DO j = 1,jjp1
627 DO i = 1,iim
628 sqf = sqf + S0(i,j,l,ntra)
629 END DO
630 END DO
631 END DO
632 PRINT*,'---------- DIAG DANS ADVY - SORTIE --------'
633 PRINT*,'sqf=',sqf
634 c print*,'ap ADVYP fin'
635
636 c-----------------------------------------------------------------
637 C
638 RETURN
639 END
640
641
642
643
644
645
646
647
648
649
650
651
652