My Project
 All Classes Files Functions Variables Macros
advxp.F
Go to the documentation of this file.
1 !
2 ! $Header$
3 !
4  SUBROUTINE advxp(LIMIT,DTX,PBARU,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 x direction c
10 c c
11 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
12 c
13 c parametres principaux du modele
14 c
15 #include "dimensions.h"
16 #include "paramet.h"
17 #include "comconst.h"
18 #include "comvert.h"
19 
20  INTEGER ntra
21 c parameter(ntra = 1)
22 c
23 c definition de la grille du modele
24 c
25  REAL dtx
26  REAL pbaru ( iip1,jjp1,llm )
27 c
28 c moments: sm total mass in each grid box
29 c s0 mass of tracer in each grid box
30 c si 1rst order moment in i direction
31 c sij 2nd order moment in i and j directions
32 c
33  REAL sm(iip1,jjp1,llm)
34  + ,s0(iip1,jjp1,llm,ntra)
35  REAL ssx(iip1,jjp1,llm,ntra)
36  + ,sy(iip1,jjp1,llm,ntra)
37  + ,sz(iip1,jjp1,llm,ntra)
38  REAL ssxx(iip1,jjp1,llm,ntra)
39  + ,ssxy(iip1,jjp1,llm,ntra)
40  + ,ssxz(iip1,jjp1,llm,ntra)
41  + ,syy(iip1,jjp1,llm,ntra)
42  + ,syz(iip1,jjp1,llm,ntra)
43  + ,szz(iip1,jjp1,llm,ntra)
44 
45 c local :
46 c -------
47 
48 c mass fluxes across the boundaries(ugri,vgri,wgri)
49 c mass fluxes in kg
50 c declaration :
51 
52  REAL ugri(iip1,jjp1,llm)
53 
54 c rem : vgri et wgri ne sont pas utilises dans
55 c cette subroutine ( advection en x uniquement )
56 c
57 c
58 c tij are the moments for the current latitude and level
59 c
60  REAL tm (iim)
61  REAL t0 (iim,ntra),tx (iim,ntra)
62  REAL ty (iim,ntra),tz (iim,ntra)
63  REAL txx(iim,ntra),txy(iim,ntra)
64  REAL txz(iim,ntra),tyy(iim,ntra)
65  REAL tyz(iim,ntra),tzz(iim,ntra)
66 c
67 c the moments f are similarly defined and used as temporary
68 c storage for portions of the grid boxes in transit
69 c
70  REAL fm (iim)
71  REAL f0 (iim,ntra),fx (iim,ntra)
72  REAL fy (iim,ntra),fz (iim,ntra)
73  REAL fxx(iim,ntra),fxy(iim,ntra)
74  REAL fxz(iim,ntra),fyy(iim,ntra)
75  REAL fyz(iim,ntra),fzz(iim,ntra)
76 c
77 c work arrays
78 c
79  REAL alf (iim),alf1(iim),alfq(iim),alf1q(iim)
80  REAL alf2(iim),alf3(iim),alf4(iim)
81 c
82  REAL smnew(iim),uext(iim)
83  REAL sqi,sqf
84  REAL temptm
85  REAL slpmax
86  REAL s1max,s1new,s2new
87 
88  LOGICAL limit
89  INTEGER num(jjp1),lonk,numk
90  INTEGER lon,lati,latf,niv
91  INTEGER i,i2,i3,j,jv,l,k,iter
92 
93  lon = iim
94  lati=2
95  latf = jjm
96  niv = llm
97 
98 c *** test de passage d
99 
100 
101 
102 
103 .lt.
104 'arguments ******c DO 399 l = 1, llmc DO 399 j = 1, jjp1c DO 399 i = 1, iip1c IF (S0(i,j,l,ntra) 0. ) THENc PRINT*,'s0(',i,j,l,')=
105 ',S0(i,j,l,ntra)c print*, 'ssx(',i,j,l,')=
106 ',SSX(i,j,l,ntra)c print*, 'sy(',i,j,l,')=
107 ',SY(i,j,l,ntra)c print*, 'sz(',i,j,l,')=
108 ',SZ(i,j,l,ntra)c PRINT*, 'aie !! debut ADVXP - pbl arg. passage dans ADVXP'
109 cc stop
110 c ENDIF
111 c 399 CONTINUE
112 
113 c *** test : diagnostique de la qtite totale de traceur
114 c dans l'atmosphere avant l'advection
115 c
116  sqi =0.
117  sqf =0.
118 c
119  DO l = 1, llm
120  DO j = 1, jjp1
121  DO i = 1, iim
122  sqi = sqi + s0(i,j,l,ntra)
123  END DO
124  END DO
125  END DO
126  print*,'------ DIAG DANS ADVX2 - ENTREE -----'
127  print*,'sqi=',sqi
128 c test
129 c -------------------------------------
130  DO 300 j =1,jjp1
131  num(j) =1
132  300 CONTINUE
133 c DO l=1,llm
134 c num(2,l)=6
135 c num(3,l)=6
136 c num(jjm-1,l)=6
137 c num(jjm,l)=6
138 c ENDDO
139 c DO j=2,6
140 c num(j)=12
141 c ENDDO
142 c DO j=jjm-5,jjm-1
143 c num(j)=12
144 c ENDDO
145 
146 c Interface : adaptation nouveau modele
147 c -------------------------------------
148 c
149 c ---------------------------------------------------------
150 c conversion des flux de masses en kg/s
151 c pbaru est en n/s d
152 
153 
154 
155 
156 
157 
158 
159 
160 
161 
162 
163 
164 
165 
166 
167 
168 
169 
170 
171 
172 
173 
174 
175 
176 
177 
178 
179 
180 
181 
182 
183 .GT.
184 
185 
186 
187 
188 
189 
190 
191 
192 
193 
194 
195 
196 
197 
198 
199 
200 
201 
202 
203 
204 
205 
206 
207 
208 
209 
210 
211 
212 
213 
214 
215 
216 
217 
218 
219 
220 
221 
222 
223 
224 
225 
226 
227 
228 
229 
230 
231 
232 
233 
234 
235 
236 
237 
238 
239 
240 
241 
242 
243 
244 
245 
246 
247 
248 
249 
250 
251 
252 
253 
254 
255 
256 
257 
258 
259 
260 
261 
262 
263 
264 
265 
266 
267 .NOT.
268 
269 
270 
271 .GT.
272 
273 
274 
275 
276 
277 
278 
279 
280 
281 
282 
283 
284 
285 
286 
287 
288 
289 
290 
291 
292 
293 
294 
295 
296 .lt.
297 
298 
299 .LT.
300 
301 
302 
303 
304 
305 
306 
307 .LT.
308 
309 
310 
311 
312 
313 .gt.
314 
315 
316 .GE.
317 
318 
319 
320 
321 
322 
323 
324 
325 
326 
327 
328 
329 
330 
331 
332 
333 
334 
335 .LT.
336 
337 
338 
339 
340 
341 
342 
343 
344 
345 
346 
347 
348 
349 
350 
351 
352 
353 
354 
355 
356 
357 
358 
359 
360 
361 
362 
363 
364 
365 
366 .LT.
367 
368 
369 
370 
371 
372 
373 
374 
375 
376 
377 
378 
379 
380 
381 
382 
383 
384 
385 
386 
387 
388 
389 
390 
391 
392 
393 
394 
395 
396 
397 
398 
399 
400 .GE.
401 
402 
403 
404 
405 
406 
407 
408 
409 
410 
411 
412 
413 
414 
415 
416 
417 
418 
419 
420 
421 
422 
423 
424 
425 
426 
427 
428 
429 
430 
431 
432 
433 .LT.
434 
435 
436 
437 
438 
439 
440 .GE.
441 
442 
443 
444 
445 
446 
447 .GE.
448 
449 
450 
451 
452 
453 
454 
455 
456 
457 
458 
459 
460 
461 
462 
463 .LT.
464 
465 
466 
467 
468 
469 
470 
471 
472 
473 
474 
475 
476 
477 
478 
479 
480 
481 
482 
483 
484 
485 
486 
487 
488 .GE.
489 
490 
491 
492 
493 
494 
495 
496 
497 
498 
499 
500 
501 
502 
503 
504 
505 
506 
507 
508 
509 
510 
511 .GE.
512 
513 
514 
515 
516 
517 
518 
519 
520 
521 
522 
523 
524 
525 
526 
527 
528 
529 
530 'ou :C ugri est en kg/s DO 500 l = 1,llm DO 500 j = 1,jjp1 DO 500 i = 1,iip1 ugri (i,j,llm+1-l) =pbaru (i,j,l) 500 CONTINUEC ---------------------------------------------------------C start hereCC boucle principale sur les niveaux et les latitudesC DO 1 L=1,NIV DO 1 K=lati,latfCC initialisationCC program assumes periodic boundaries in XC DO 10 I=2,LON SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX 10 CONTINUE SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTXCC modifications for extended polar zonesC NUMK=NUM(K) LONK=LON/NUMKC IF(NUMK1) THENC DO 111 I=1,LON TM(I)=0. 111 CONTINUE DO 112 JV=1,NTRA DO 1120 I=1,LON T0 (I,JV)=0. TX (I,JV)=0. TY (I,JV)=0. TZ (I,JV)=0. TXX(I,JV)=0. TXY(I,JV)=0. TXZ(I,JV)=0. TYY(I,JV)=0. TYZ(I,JV)=0. TZZ(I,JV)=0. 1120 CONTINUE 112 CONTINUEC DO 11 I2=1,NUMKC DO 113 I=1,LONK I3=(I-1)*NUMK+I2 TM(I)=TM(I)+SM(I3,K,L) ALF(I)=SM(I3,K,L)/TM(I) ALF1(I)=1.-ALF(I) ALFQ(I)=ALF(I)*ALF(I) ALF1Q(I)=ALF1(I)*ALF1(I) ALF2(I)=ALF1(I)-ALF(I) ALF3(I)=ALF(I)*ALF1(I) 113 CONTINUEC DO 114 JV=1,NTRA DO 1140 I=1,LONK I3=(I-1)*NUMK+I2 TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV) T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV) TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV) + +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV) + +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV)) TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV) + +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV)) TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV) TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV) TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV) TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV) TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV) 1140 CONTINUE 114 CONTINUEC 11 CONTINUEC ELSEC DO 115 I=1,LON TM(I)=SM(I,K,L) 115 CONTINUE DO 116 JV=1,NTRA DO 1160 I=1,LON T0 (I,JV)=S0 (I,K,L,JV) TX (I,JV)=SSX (I,K,L,JV) TY (I,JV)=SY (I,K,L,JV) TZ (I,JV)=SZ (I,K,L,JV) TXX(I,JV)=SSXX(I,K,L,JV) TXY(I,JV)=SSXY(I,K,L,JV) TXZ(I,JV)=SSXZ(I,K,L,JV) TYY(I,JV)=SYY(I,K,L,JV) TYZ(I,JV)=SYZ(I,K,L,JV) TZZ(I,JV)=SZZ(I,K,L,JV) 1160 CONTINUE 116 CONTINUEC ENDIFC DO 117 I=1,LONK UEXT(I)=UGRI(I*NUMK,K,L) 117 CONTINUECC place limits on appropriate moments before transportC (if flux-limiting is to be applied)C IF(LIMIT) GO TO 13C DO 12 JV=1,NTRA DO 120 I=1,LONK IF(T0(I,JV)0.) THEN SLPMAX=T0(I,JV) S1MAX=1.5*SLPMAX S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV))) S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) ) TX (I,JV)=S1NEW TXX(I,JV)=S2NEW TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV))) TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV))) ELSE TX (I,JV)=0. TXX(I,JV)=0. TXY(I,JV)=0. TXZ(I,JV)=0. ENDIF 120 CONTINUE 12 CONTINUEC 13 CONTINUECC calculate flux and moments between adjacent boxesC 1- create temporary moments/masses for partial boxes in transitC 2- reajusts moments remaining in the boxCC flux from IP to I if U(I)0C DO 140 I=1,LONK-1 IF(UEXT(I)0.) THEN FM(I)=-UEXT(I)*DTX ALF(I)=FM(I)/TM(I+1) TM(I+1)=TM(I+1)-FM(I) ENDIF 140 CONTINUEC I=LONK IF(UEXT(I)0.) THEN FM(I)=-UEXT(I)*DTX ALF(I)=FM(I)/TM(1) TM(1)=TM(1)-FM(I) ENDIFCC flux from I to IP if U(I)0C DO 141 I=1,LONK IF(UEXT(I)0.) THEN FM(I)=UEXT(I)*DTX ALF(I)=FM(I)/TM(I) TM(I)=TM(I)-FM(I) ENDIF 141 CONTINUEC DO 142 I=1,LONK ALFQ(I)=ALF(I)*ALF(I) ALF1(I)=1.-ALF(I) ALF1Q(I)=ALF1(I)*ALF1(I) ALF2(I)=ALF1(I)-ALF(I) ALF3(I)=ALF(I)*ALFQ(I) ALF4(I)=ALF1(I)*ALF1Q(I) 142 CONTINUEC DO 150 JV=1,NTRA DO 1500 I=1,LONK-1C IF(UEXT(I)0.) THENC F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)* + ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) ) FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV)) FXX(I,JV)=ALF3(I)*TXX(I+1,JV) FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV)) FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV)) FXY(I,JV)=ALFQ(I)*TXY(I+1,JV) FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV) FYY(I,JV)=ALF (I)*TYY(I+1,JV) FYZ(I,JV)=ALF (I)*TYZ(I+1,JV) FZZ(I,JV)=ALF (I)*TZZ(I+1,JV)C T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV) TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV)) TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV) TY (I+1,JV)=TY (I+1,JV)-FY (I,JV) TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV) TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV) TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV) TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV) TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV) TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV)C ENDIFC 1500 CONTINUE 150 CONTINUEC I=LONK IF(UEXT(I)0.) THENC DO 151 JV=1,NTRAC F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)* + ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) ) FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV)) FXX(I,JV)=ALF3(I)*TXX(1,JV) FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV)) FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV)) FXY(I,JV)=ALFQ(I)*TXY(1,JV) FXZ(I,JV)=ALFQ(I)*TXZ(1,JV) FYY(I,JV)=ALF (I)*TYY(1,JV) FYZ(I,JV)=ALF (I)*TYZ(1,JV) FZZ(I,JV)=ALF (I)*TZZ(1,JV)C T0 (1,JV)=T0(1,JV)-F0(I,JV) TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV)) TXX(1,JV)=ALF4(I)*TXX(1,JV) TY (1,JV)=TY (1,JV)-FY (I,JV) TZ (1,JV)=TZ (1,JV)-FZ (I,JV) TYY(1,JV)=TYY(1,JV)-FYY(I,JV) TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV) TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV) TXY(1,JV)=ALF1Q(I)*TXY(1,JV) TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV)C 151 CONTINUEC ENDIFC DO 152 JV=1,NTRA DO 1520 I=1,LONKC IF(UEXT(I)0.) THENC F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)* + ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) ) FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV)) FXX(I,JV)=ALF3(I)*TXX(I,JV) FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV)) FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV)) FXY(I,JV)=ALFQ(I)*TXY(I,JV) FXZ(I,JV)=ALFQ(I)*TXZ(I,JV) FYY(I,JV)=ALF (I)*TYY(I,JV) FYZ(I,JV)=ALF (I)*TYZ(I,JV) FZZ(I,JV)=ALF (I)*TZZ(I,JV)C T0 (I,JV)=T0(I,JV)-F0(I,JV) TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV)) TXX(I,JV)=ALF4(I)*TXX(I,JV) TY (I,JV)=TY (I,JV)-FY (I,JV) TZ (I,JV)=TZ (I,JV)-FZ (I,JV) TYY(I,JV)=TYY(I,JV)-FYY(I,JV) TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV) TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV) TXY(I,JV)=ALF1Q(I)*TXY(I,JV) TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)C ENDIFC 1520 CONTINUE 152 CONTINUECC puts the temporary moments Fi into appropriate neighboring boxesC DO 160 I=1,LONK IF(UEXT(I)0.) THEN TM(I)=TM(I)+FM(I) ALF(I)=FM(I)/TM(I) ENDIF 160 CONTINUEC DO 161 I=1,LONK-1 IF(UEXT(I)0.) THEN TM(I+1)=TM(I+1)+FM(I) ALF(I)=FM(I)/TM(I+1) ENDIF 161 CONTINUEC I=LONK IF(UEXT(I)0.) THEN TM(1)=TM(1)+FM(I) ALF(I)=FM(I)/TM(1) ENDIFC DO 162 I=1,LONK ALF1(I)=1.-ALF(I) ALFQ(I)=ALF(I)*ALF(I) ALF1Q(I)=ALF1(I)*ALF1(I) ALF2(I)=ALF1(I)-ALF(I) ALF3(I)=ALF(I)*ALF1(I) 162 CONTINUEC DO 170 JV=1,NTRA DO 1700 I=1,LONKC IF(UEXT(I)0.) THENC TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV) T0 (I,JV)=T0(I,JV)+F0(I,JV) TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV) + +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV) + +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV)) TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV) + +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV)) TY (I,JV)=TY (I,JV)+FY (I,JV) TZ (I,JV)=TZ (I,JV)+FZ (I,JV) TYY(I,JV)=TYY(I,JV)+FYY(I,JV) TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV) TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV)C ENDIFC 1700 CONTINUE 170 CONTINUEC DO 171 JV=1,NTRA DO 1710 I=1,LONK-1C IF(UEXT(I)0.) THENC TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV) T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV) TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV) + +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) TX (I+1,JV)=ALF(I)*FX (I ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM TXY(I+1,JV)=ALF(I)*FXY(I ,JV)+ALF1(I)*TXY(I+1,JV) + +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I ,JV)) TXZ(I+1,JV)=ALF(I)*FXZ(I ,JV)+ALF1(I)*TXZ(I+1,JV) + +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I ,JV)) TY (I+1,JV)=TY (I+1,JV)+FY (I,JV) TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV) TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV) TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV) TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV)C ENDIFC 1710 CONTINUE 171 CONTINUEC I=LONK IF(UEXT(I)0.) THEN DO 172 JV=1,NTRA TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV) T0 (1,JV)=T0(1,JV)+F0(I,JV) TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV) + +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV) + +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV)) TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV) + +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV)) TY (1,JV)=TY (1,JV)+FY (I,JV) TZ (1,JV)=TZ (1,JV)+FZ (I,JV) TYY(1,JV)=TYY(1,JV)+FYY(I,JV) TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV) TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV) 172 CONTINUE ENDIFCC retour aux mailles d'origine(passage des tij aux sij)
531 c
532  IF(numk.GT.1) THEN
533 c
534  DO 18 i2=1,numk
535 c
536  DO 180 i=1,lonk
537 c
538  i3=i2+(i-1)*numk
539  sm(i3,k,l)=smnew(i3)
540  alf(i)=smnew(i3)/tm(i)
541  tm(i)=tm(i)-smnew(i3)
542 c
543  alfq(i)=alf(i)*alf(i)
544  alf1(i)=1.-alf(i)
545  alf1q(i)=alf1(i)*alf1(i)
546  alf2(i)=alf1(i)-alf(i)
547  alf3(i)=alf(i)*alfq(i)
548  alf4(i)=alf1(i)*alf1q(i)
549 c
550  180 CONTINUE
551 c
552  DO 181 jv=1,ntra
553  DO 181 i=1,lonk
554 c
555  i3=i2+(i-1)*numk
556  s0(i3,k,l,jv)=alf(i)* ( t0(i,jv)-alf1(i)*
557  + ( tx(i,jv)-alf2(i)*txx(i,jv) ) )
558  ssx(i3,k,l,jv)=alfq(i)*(tx(i,jv)-3.*alf1(i)*txx(i,jv))
559  ssxx(i3,k,l,jv)=alf3(i)*txx(i,jv)
560  sy(i3,k,l,jv)=alf(i)*(ty(i,jv)-alf1(i)*txy(i,jv))
561  sz(i3,k,l,jv)=alf(i)*(tz(i,jv)-alf1(i)*txz(i,jv))
562  ssxy(i3,k,l,jv)=alfq(i)*txy(i,jv)
563  ssxz(i3,k,l,jv)=alfq(i)*txz(i,jv)
564  syy(i3,k,l,jv)=alf(i)*tyy(i,jv)
565  syz(i3,k,l,jv)=alf(i)*tyz(i,jv)
566  szz(i3,k,l,jv)=alf(i)*tzz(i,jv)
567 c
568 c reajusts moments remaining in the box
569 c
570  t0(i,jv)=t0(i,jv)-s0(i3,k,l,jv)
571  tx(i,jv)=alf1q(i)*(tx(i,jv)+3.*alf(i)*txx(i,jv))
572  txx(i,jv)=alf4(i)*txx(i,jv)
573  ty(i,jv)=ty(i,jv)-sy(i3,k,l,jv)
574  tz(i,jv)=tz(i,jv)-sz(i3,k,l,jv)
575  tyy(i,jv)=tyy(i,jv)-syy(i3,k,l,jv)
576  tyz(i,jv)=tyz(i,jv)-syz(i3,k,l,jv)
577  tzz(i,jv)=tzz(i,jv)-szz(i3,k,l,jv)
578  txy(i,jv)=alf1q(i)*txy(i,jv)
579  txz(i,jv)=alf1q(i)*txz(i,jv)
580 c
581  181 CONTINUE
582 c
583  18 CONTINUE
584 c
585  ELSE
586 c
587  DO 190 i=1,lon
588  sm(i,k,l)=tm(i)
589  190 CONTINUE
590  DO 191 jv=1,ntra
591  DO 1910 i=1,lon
592  s0(i,k,l,jv)=t0(i,jv)
593  ssx(i,k,l,jv)=tx(i,jv)
594  sy(i,k,l,jv)=ty(i,jv)
595  sz(i,k,l,jv)=tz(i,jv)
596  ssxx(i,k,l,jv)=txx(i,jv)
597  ssxy(i,k,l,jv)=txy(i,jv)
598  ssxz(i,k,l,jv)=txz(i,jv)
599  syy(i,k,l,jv)=tyy(i,jv)
600  syz(i,k,l,jv)=tyz(i,jv)
601  szz(i,k,l,jv)=tzz(i,jv)
602  1910 CONTINUE
603  191 CONTINUE
604 c
605  ENDIF
606 c
607  1 CONTINUE
608 c
609 c ----------- aa test en fin de advx ------ controle des s*
610 
611 c DO 9999 l = 1, llm
612 c DO 9999 j = 1, jjp1
613 c DO 9999 i = 1, iip1
614 c IF (s0(i,j,l,ntra).lt.0..and.limit) THEN
615 c print*, '-------------------'
616 c print*, 'En fin de ADVXP'
617 c print*,'S0(',i,j,l,')=',s0(i,j,l,ntra)
618 c print*, 'SSX(',i,j,l,')=',ssx(i,j,l,ntra)
619 c print*, 'SY(',i,j,l,')=',sy(i,j,l,ntra)
620 c print*, 'SZ(',i,j,l,')=',sz(i,j,l,ntra)
621 c WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP'
622 c stop
623 c ENDIF
624 c 9999 CONTINUE
625 c ---------- bouclage cyclique
626 
627  DO l = 1,llm
628  DO j = 1,jjp1
629  sm(iip1,j,l) = sm(1,j,l)
630  s0(iip1,j,l,ntra) = s0(1,j,l,ntra)
631  ssx(iip1,j,l,ntra) = ssx(1,j,l,ntra)
632  sy(iip1,j,l,ntra) = sy(1,j,l,ntra)
633  sz(iip1,j,l,ntra) = sz(1,j,l,ntra)
634  END DO
635  END DO
636 
637 c ----------- qqtite totale de traceur dans tte l
638 
639 
640 
641 
642 
643 
644 
645 
646 'atmosphere DO l = 1, llm DO j = 1, jjp1 DO i = 1, iim sqf = sqf + S0(i,j,l,ntra) END DO END DO END DO PRINT*,'------ diag dans advx2 - sortie -----
647 ' PRINT*,'sqf=
648 
649 
650