/[lmdze]/trunk/dyn3d/advx.f90
ViewVC logotype

Diff of /trunk/dyn3d/advx.f90

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/dyn3d/advx.f revision 80 by guez, Fri Nov 15 18:45:49 2013 UTC trunk/dyn3d/advx.f90 revision 81 by guez, Wed Mar 5 14:38:41 2014 UTC
# Line 1  Line 1 
1  !  
2  ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/advx.F,v 1.2 2005/05/25 13:10:09 fairhead Exp $  ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/advx.F,v 1.2 2005/05/25 13:10:09
3  !  ! fairhead Exp $
4        SUBROUTINE  advx(limit,dtx,pbaru,sm,s0,  
5       $     sx,sy,sz,lati,latf)  SUBROUTINE advx(limit, dtx, pbaru, sm, s0, sx, sy, sz, lati, latf)
6        use dimens_m    USE dimens_m
7        use paramet_m    USE paramet_m
8        use comconst    USE comconst
9        use disvert_m    USE disvert_m
10        IMPLICIT NONE    IMPLICIT NONE
11    
12  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC    ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
13  C                                                                C    ! C
14  C  first-order moments (FOM) advection of tracer in X direction  C    ! first-order moments (FOM) advection of tracer in X direction  C
15  C                                                                C    ! C
16  C  Source : Pascal Simon (Meteo,CNRM)                            C    ! Source : Pascal Simon (Meteo,CNRM)                            C
17  C  Adaptation : A.Armengaud (LGGE) juin 94                       C    ! Adaptation : A.Armengaud (LGGE) juin 94                       C
18  C                                                                C    ! C
19  C  limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz                       C    ! limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz                       C
20  C  sont des arguments d'entree pour le s-pg...                   C    ! sont des arguments d'entree pour le s-pg...                   C
21  C                                                                C    ! C
22  C  sm,s0,sx,sy,sz                                                C    ! sm,s0,sx,sy,sz                                                C
23  C  sont les arguments de sortie pour le s-pg                     C    ! sont les arguments de sortie pour le s-pg                     C
24  C                                                                C    ! C
25  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC    ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26  C  
27  C  parametres principaux du modele    ! parametres principaux du modele
28  C  
29    
30  C  Arguments :    ! Arguments :
31  C  -----------    ! -----------
32  C  dtx : frequence fictive d'appel du transport    ! dtx : frequence fictive d'appel du transport
33  C  pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1    ! pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1
34    
35         INTEGER ntra    INTEGER ntra
36         PARAMETER (ntra = 1)    PARAMETER (ntra=1)
37    
38  C ATTENTION partout ou on trouve ntra, insertion de boucle    ! ATTENTION partout ou on trouve ntra, insertion de boucle
39  C           possible dans l'avenir.    ! possible dans l'avenir.
40    
41        REAL dtx    REAL dtx
42        REAL, intent(in):: pbaru ( iip1,jjp1,llm )    REAL, INTENT (IN) :: pbaru(iip1, jjp1, llm)
43    
44  C  moments: SM  total mass in each grid box    ! moments: SM  total mass in each grid box
45  C           S0  mass of tracer in each grid box    ! S0  mass of tracer in each grid box
46  C           Si  1rst order moment in i direction    ! Si  1rst order moment in i direction
47  C  
48        REAL SM(iip1,jjp1,llm),S0(iip1,jjp1,llm,ntra)    REAL sm(iip1, jjp1, llm), s0(iip1, jjp1, llm, ntra)
49        REAL sx(iip1,jjp1,llm,ntra)    REAL sx(iip1, jjp1, llm, ntra), sy(iip1, jjp1, llm, ntra)
50       $    ,sy(iip1,jjp1,llm,ntra)    REAL sz(iip1, jjp1, llm, ntra)
51        REAL sz(iip1,jjp1,llm,ntra)  
52      ! Local :
53  C  Local :    ! -------
54  C  -------  
55      ! mass fluxes across the boundaries (UGRI,VGRI,WGRI)
56  C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)    ! mass fluxes in kg
57  C  mass fluxes in kg    ! declaration :
58  C  declaration :  
59      REAL ugri(iip1, jjp1, llm)
60        REAL UGRI(iip1,jjp1,llm)  
61      ! Rem : VGRI et WGRI ne sont pas utilises dans
62  C  Rem : VGRI et WGRI ne sont pas utilises dans    ! cette subroutine ( advection en x uniquement )
63  C  cette subroutine ( advection en x uniquement )  
64  C    ! Ti are the moments for the current latitude and level
65  C  Ti are the moments for the current latitude and level  
66  C    REAL tm(iim)
67        REAL TM(iim)    REAL t0(iim, ntra), tx(iim, ntra)
68        REAL T0(iim,ntra),TX(iim,ntra)    REAL ty(iim, ntra), tz(iim, ntra)
69        REAL TY(iim,ntra),TZ(iim,ntra)    REAL temptm ! just a temporary variable
70        REAL TEMPTM                ! just a temporary variable  
71  C    ! the moments F are similarly defined and used as temporary
72  C  the moments F are similarly defined and used as temporary    ! storage for portions of the grid boxes in transit
73  C  storage for portions of the grid boxes in transit  
74  C    REAL fm(iim)
75        REAL FM(iim)    REAL f0(iim, ntra), fx(iim, ntra)
76        REAL F0(iim,ntra),FX(iim,ntra)    REAL fy(iim, ntra), fz(iim, ntra)
77        REAL FY(iim,ntra),FZ(iim,ntra)  
78  C    ! work arrays
79  C  work arrays  
80  C    REAL alf(iim), alf1(iim), alfq(iim), alf1q(iim)
81        REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)  
82  C    REAL smnew(iim), uext(iim)
83        REAL SMNEW(iim),UEXT(iim)  
84  C    REAL sqi, sqf
85        REAL sqi,sqf  
86      LOGICAL limit
87        LOGICAL LIMIT    INTEGER num(jjp1), lonk, numk
88        INTEGER NUM(jjp1),LONK,NUMK    INTEGER lon, lati, latf, niv
89        INTEGER lon,lati,latf,niv    INTEGER i, i2, i3, j, jv, l, k, itrac
90        INTEGER i,i2,i3,j,jv,l,k,itrac  
91      lon = iim
92        lon = iim    niv = llm
93        niv = llm  
94      ! *** Test de passage d'arguments ******
95  C *** Test de passage d'arguments ******  
96    
97      ! -------------------------------------
98  C  -------------------------------------    DO j = 1, jjp1
99        DO 300 j = 1,jjp1      num(j) = 1
100           NUM(j) = 1    END DO
101    300 CONTINUE    sqi = 0.
102        sqi = 0.    sqf = 0.
103        sqf = 0.  
104      DO l = 1, llm
105        DO l = 1,llm      DO j = 1, jjp1
106           DO j = 1,jjp1        DO i = 1, iim
107              DO i = 1,iim          ! IM 240305            sqi = sqi + S0(i,j,l,9)
108  cIM 240305            sqi = sqi + S0(i,j,l,9)          sqi = sqi + s0(i, j, l, ntra)
109                 sqi = sqi + S0(i,j,l,ntra)        END DO
110              ENDDO      END DO
111           ENDDO    END DO
112        ENDDO    PRINT *, '-------- DIAG DANS ADVX - ENTREE ---------'
113        PRINT*,'-------- DIAG DANS ADVX - ENTREE ---------'    PRINT *, 'sqi=', sqi
114        PRINT*,'sqi=',sqi  
115    
116      ! Interface : adaptation nouveau modele
117  C  Interface : adaptation nouveau modele    ! -------------------------------------
118  C  -------------------------------------  
119  C    ! ---------------------------------------------------------
120  C  ---------------------------------------------------------    ! Conversion des flux de masses en kg/s
121  C  Conversion des flux de masses en kg/s    ! pbaru est en N/s d'ou :
122  C  pbaru est en N/s d'ou :    ! ugri est en kg/s
123  C  ugri est en kg/s  
124      DO l = 1, llm
125        DO 500 l = 1,llm      DO j = 1, jjm + 1
126           DO 500 j = 1,jjm+1        DO i = 1, iip1
127              DO 500 i = 1,iip1            ! ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g )
128  C            ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g )          ugri(i, j, llm+1-l) = pbaru(i, j, l)
129               ugri (i,j,llm+1-l) = pbaru (i,j,l)        END DO
130    500 CONTINUE      END DO
131      END DO
132    
133  C  ---------------------------------------------------------  
134  C  ---------------------------------------------------------    ! ---------------------------------------------------------
135  C  ---------------------------------------------------------    ! ---------------------------------------------------------
136        ! ---------------------------------------------------------
137  C  start here            
138  C    ! start here
139  C  boucle principale sur les niveaux et les latitudes  
140  C    ! boucle principale sur les niveaux et les latitudes
141        DO 1 L=1,NIV  
142        DO 1 K=lati,latf    DO l = 1, niv
143  C      DO k = lati, latf
144  C  initialisation  
145  C        ! initialisation
146  C  program assumes periodic boundaries in X  
147  C        ! program assumes periodic boundaries in X
148        DO 10 I=2,LON  
149           SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX        DO i = 2, lon
150   10   CONTINUE          smnew(i) = sm(i, k, l) + (ugri(i-1,k,l)-ugri(i,k,l))*dtx
151        SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX        END DO
152  C        smnew(1) = sm(1, k, l) + (ugri(lon,k,l)-ugri(1,k,l))*dtx
153  C  modifications for extended polar zones  
154  C        ! modifications for extended polar zones
155        NUMK=NUM(K)  
156        LONK=LON/NUMK        numk = num(k)
157  C        lonk = lon/numk
158        IF(NUMK.GT.1) THEN  
159  C        IF (numk>1) THEN
160        DO 111 I=1,LON  
161           TM(I)=0.          DO i = 1, lon
162   111  CONTINUE            tm(i) = 0.
163        DO 112 JV=1,NTRA          END DO
164        DO 1120 I=1,LON          DO jv = 1, ntra
165           T0(I,JV)=0.            DO i = 1, lon
166           TX(I,JV)=0.              t0(i, jv) = 0.
167           TY(I,JV)=0.              tx(i, jv) = 0.
168           TZ(I,JV)=0.              ty(i, jv) = 0.
169   1120 CONTINUE              tz(i, jv) = 0.
170   112  CONTINUE            END DO
171  C          END DO
172        DO 11 I2=1,NUMK  
173  C          DO i2 = 1, numk
174           DO 113 I=1,LONK  
175              I3=(I-1)*NUMK+I2            DO i = 1, lonk
176              TM(I)=TM(I)+SM(I3,K,L)              i3 = (i-1)*numk + i2
177              ALF(I)=SM(I3,K,L)/TM(I)              tm(i) = tm(i) + sm(i3, k, l)
178              ALF1(I)=1.-ALF(I)              alf(i) = sm(i3, k, l)/tm(i)
179   113     CONTINUE              alf1(i) = 1. - alf(i)
180  C            END DO
181           DO  JV=1,NTRA  
182           DO  I=1,LONK            DO jv = 1, ntra
183              I3=(I-1)*NUMK+I2              DO i = 1, lonk
184              TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)                i3 = (i-1)*numk + i2
185       $          *S0(I3,K,L,JV)                temptm = -alf(i)*t0(i, jv) + alf1(i)*s0(i3, k, l, jv)
186              T0(I,JV)=T0(I,JV)+S0(I3,K,L,JV)                t0(i, jv) = t0(i, jv) + s0(i3, k, l, jv)
187              TX(I,JV)=ALF(I)  *sx(I3,K,L,JV)+                tx(i, jv) = alf(i)*sx(i3, k, l, jv) + alf1(i)*tx(i, jv) + &
188       $       ALF1(I)*TX(I,JV) +3.*TEMPTM                  3.*temptm
189              TY(I,JV)=TY(I,JV)+sy(I3,K,L,JV)                ty(i, jv) = ty(i, jv) + sy(i3, k, l, jv)
190              TZ(I,JV)=TZ(I,JV)+sz(I3,K,L,JV)                tz(i, jv) = tz(i, jv) + sz(i3, k, l, jv)
191           ENDDO              END DO
192           ENDDO            END DO
193  C  
194   11   CONTINUE          END DO
195  C  
196        ELSE        ELSE
197  C  
198        DO 115 I=1,LON          DO i = 1, lon
199           TM(I)=SM(I,K,L)            tm(i) = sm(i, k, l)
200   115  CONTINUE          END DO
201        DO 116 JV=1,NTRA          DO jv = 1, ntra
202        DO 1160 I=1,LON            DO i = 1, lon
203           T0(I,JV)=S0(I,K,L,JV)              t0(i, jv) = s0(i, k, l, jv)
204           TX(I,JV)=sx(I,K,L,JV)              tx(i, jv) = sx(i, k, l, jv)
205           TY(I,JV)=sy(I,K,L,JV)              ty(i, jv) = sy(i, k, l, jv)
206           TZ(I,JV)=sz(I,K,L,JV)              tz(i, jv) = sz(i, k, l, jv)
207   1160 CONTINUE            END DO
208   116  CONTINUE          END DO
209  C  
210        ENDIF        END IF
211  C  
212        DO 117 I=1,LONK        DO i = 1, lonk
213           UEXT(I)=UGRI(I*NUMK,K,L)          uext(i) = ugri(i*numk, k, l)
214   117  CONTINUE        END DO
215  C  
216  C  place limits on appropriate moments before transport        ! place limits on appropriate moments before transport
217  C      (if flux-limiting is to be applied)        ! (if flux-limiting is to be applied)
218  C  
219        IF(.NOT.LIMIT) GO TO 13        IF (.NOT. limit) GO TO 13
220  C  
221        DO 12 JV=1,NTRA        DO jv = 1, ntra
222        DO 120 I=1,LONK          DO i = 1, lonk
223          TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV))            tx(i, jv) = sign(amin1(amax1(t0(i,jv),0.),abs(tx(i,jv))), tx(i,jv))
224   120  CONTINUE          END DO
225   12   CONTINUE        END DO
226  C  
227   13   CONTINUE  13    CONTINUE
228  C  
229  C  calculate flux and moments between adjacent boxes        ! calculate flux and moments between adjacent boxes
230  C  1- create temporary moments/masses for partial boxes in transit        ! 1- create temporary moments/masses for partial boxes in transit
231  C  2- reajusts moments remaining in the box        ! 2- reajusts moments remaining in the box
232  C  
233  C  flux from IP to I if U(I).lt.0        ! flux from IP to I if U(I).lt.0
234  C  
235        DO 140 I=1,LONK-1        DO i = 1, lonk - 1
236           IF(UEXT(I).LT.0.) THEN          IF (uext(i)<0.) THEN
237             FM(I)=-UEXT(I)*DTX            fm(i) = -uext(i)*dtx
238             ALF(I)=FM(I)/TM(I+1)            alf(i) = fm(i)/tm(i+1)
239             TM(I+1)=TM(I+1)-FM(I)            tm(i+1) = tm(i+1) - fm(i)
240           ENDIF          END IF
241   140  CONTINUE        END DO
242  C  
243        I=LONK        i = lonk
244        IF(UEXT(I).LT.0.) THEN        IF (uext(i)<0.) THEN
245          FM(I)=-UEXT(I)*DTX          fm(i) = -uext(i)*dtx
246          ALF(I)=FM(I)/TM(1)          alf(i) = fm(i)/tm(1)
247          TM(1)=TM(1)-FM(I)          tm(1) = tm(1) - fm(i)
248        ENDIF        END IF
249  C  
250  C  flux from I to IP if U(I).gt.0        ! flux from I to IP if U(I).gt.0
251  C  
252        DO 141 I=1,LONK        DO i = 1, lonk
253           IF(UEXT(I).GE.0.) THEN          IF (uext(i)>=0.) THEN
254             FM(I)=UEXT(I)*DTX            fm(i) = uext(i)*dtx
255             ALF(I)=FM(I)/TM(I)            alf(i) = fm(i)/tm(i)
256             TM(I)=TM(I)-FM(I)            tm(i) = tm(i) - fm(i)
257           ENDIF          END IF
258   141  CONTINUE        END DO
259  C  
260        DO 142 I=1,LONK        DO i = 1, lonk
261           ALFQ(I)=ALF(I)*ALF(I)          alfq(i) = alf(i)*alf(i)
262           ALF1(I)=1.-ALF(I)          alf1(i) = 1. - alf(i)
263           ALF1Q(I)=ALF1(I)*ALF1(I)          alf1q(i) = alf1(i)*alf1(i)
264   142  CONTINUE        END DO
265  C  
266        DO 150 JV=1,NTRA        DO jv = 1, ntra
267        DO 1500 I=1,LONK-1          DO i = 1, lonk - 1
268  C  
269           IF(UEXT(I).LT.0.) THEN            IF (uext(i)<0.) THEN
270  C  
271             F0(I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*TX(I+1,JV) )              f0(i, jv) = alf(i)*(t0(i+1,jv)-alf1(i)*tx(i+1,jv))
272             FX(I,JV)=ALFQ(I)*TX(I+1,JV)              fx(i, jv) = alfq(i)*tx(i+1, jv)
273             FY(I,JV)=ALF (I)*TY(I+1,JV)              fy(i, jv) = alf(i)*ty(i+1, jv)
274             FZ(I,JV)=ALF (I)*TZ(I+1,JV)              fz(i, jv) = alf(i)*tz(i+1, jv)
275  C  
276             T0(I+1,JV)=T0(I+1,JV)-F0(I,JV)              t0(i+1, jv) = t0(i+1, jv) - f0(i, jv)
277             TX(I+1,JV)=ALF1Q(I)*TX(I+1,JV)              tx(i+1, jv) = alf1q(i)*tx(i+1, jv)
278             TY(I+1,JV)=TY(I+1,JV)-FY(I,JV)              ty(i+1, jv) = ty(i+1, jv) - fy(i, jv)
279             TZ(I+1,JV)=TZ(I+1,JV)-FZ(I,JV)              tz(i+1, jv) = tz(i+1, jv) - fz(i, jv)
280  C  
281           ENDIF            END IF
282  C  
283   1500 CONTINUE          END DO
284   150  CONTINUE        END DO
285  C  
286        I=LONK        i = lonk
287        IF(UEXT(I).LT.0.) THEN        IF (uext(i)<0.) THEN
288  C  
289          DO 151 JV=1,NTRA          DO jv = 1, ntra
290  C  
291             F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*TX(1,JV) )            f0(i, jv) = alf(i)*(t0(1,jv)-alf1(i)*tx(1,jv))
292             FX (I,JV)=ALFQ(I)*TX(1,JV)            fx(i, jv) = alfq(i)*tx(1, jv)
293             FY (I,JV)=ALF (I)*TY(1,JV)            fy(i, jv) = alf(i)*ty(1, jv)
294             FZ (I,JV)=ALF (I)*TZ(1,JV)            fz(i, jv) = alf(i)*tz(1, jv)
295  C  
296             T0(1,JV)=T0(1,JV)-F0(I,JV)            t0(1, jv) = t0(1, jv) - f0(i, jv)
297             TX(1,JV)=ALF1Q(I)*TX(1,JV)            tx(1, jv) = alf1q(i)*tx(1, jv)
298             TY(1,JV)=TY(1,JV)-FY(I,JV)            ty(1, jv) = ty(1, jv) - fy(i, jv)
299             TZ(1,JV)=TZ(1,JV)-FZ(I,JV)            tz(1, jv) = tz(1, jv) - fz(i, jv)
300  C  
301   151    CONTINUE          END DO
302  C  
303        ENDIF        END IF
304  C  
305        DO 152 JV=1,NTRA        DO jv = 1, ntra
306        DO 1520 I=1,LONK          DO i = 1, lonk
307  C  
308           IF(UEXT(I).GE.0.) THEN            IF (uext(i)>=0.) THEN
309  C  
310             F0(I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*TX(I,JV) )              f0(i, jv) = alf(i)*(t0(i,jv)+alf1(i)*tx(i,jv))
311             FX(I,JV)=ALFQ(I)*TX(I,JV)              fx(i, jv) = alfq(i)*tx(i, jv)
312             FY(I,JV)=ALF (I)*TY(I,JV)              fy(i, jv) = alf(i)*ty(i, jv)
313             FZ(I,JV)=ALF (I)*TZ(I,JV)              fz(i, jv) = alf(i)*tz(i, jv)
314  C  
315             T0(I,JV)=T0(I,JV)-F0(I,JV)              t0(i, jv) = t0(i, jv) - f0(i, jv)
316             TX(I,JV)=ALF1Q(I)*TX(I,JV)              tx(i, jv) = alf1q(i)*tx(i, jv)
317             TY(I,JV)=TY(I,JV)-FY(I,JV)              ty(i, jv) = ty(i, jv) - fy(i, jv)
318             TZ(I,JV)=TZ(I,JV)-FZ(I,JV)              tz(i, jv) = tz(i, jv) - fz(i, jv)
319  C  
320           ENDIF            END IF
321  C  
322   1520 CONTINUE          END DO
323   152  CONTINUE        END DO
324  C  
325  C  puts the temporary moments Fi into appropriate neighboring boxes        ! puts the temporary moments Fi into appropriate neighboring boxes
326  C  
327        DO 160 I=1,LONK        DO i = 1, lonk
328           IF(UEXT(I).LT.0.) THEN          IF (uext(i)<0.) THEN
329             TM(I)=TM(I)+FM(I)            tm(i) = tm(i) + fm(i)
330             ALF(I)=FM(I)/TM(I)            alf(i) = fm(i)/tm(i)
331           ENDIF          END IF
332   160  CONTINUE        END DO
333  C  
334        DO 161 I=1,LONK-1        DO i = 1, lonk - 1
335           IF(UEXT(I).GE.0.) THEN          IF (uext(i)>=0.) THEN
336             TM(I+1)=TM(I+1)+FM(I)            tm(i+1) = tm(i+1) + fm(i)
337             ALF(I)=FM(I)/TM(I+1)            alf(i) = fm(i)/tm(i+1)
338           ENDIF          END IF
339   161  CONTINUE        END DO
340  C  
341        I=LONK        i = lonk
342        IF(UEXT(I).GE.0.) THEN        IF (uext(i)>=0.) THEN
343          TM(1)=TM(1)+FM(I)          tm(1) = tm(1) + fm(i)
344          ALF(I)=FM(I)/TM(1)          alf(i) = fm(i)/tm(1)
345        ENDIF        END IF
346  C  
347        DO 162 I=1,LONK        DO i = 1, lonk
348           ALF1(I)=1.-ALF(I)          alf1(i) = 1. - alf(i)
349   162  CONTINUE        END DO
350  C  
351        DO 170 JV=1,NTRA        DO jv = 1, ntra
352        DO 1700 I=1,LONK          DO i = 1, lonk
353  C  
354           IF(UEXT(I).LT.0.) THEN            IF (uext(i)<0.) THEN
355  C  
356             TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)              temptm = -alf(i)*t0(i, jv) + alf1(i)*f0(i, jv)
357             T0(I,JV)=T0(I,JV)+F0(I,JV)              t0(i, jv) = t0(i, jv) + f0(i, jv)
358             TX(I,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM              tx(i, jv) = alf(i)*fx(i, jv) + alf1(i)*tx(i, jv) + 3.*temptm
359             TY(I,JV)=TY(I,JV)+FY(I,JV)              ty(i, jv) = ty(i, jv) + fy(i, jv)
360             TZ(I,JV)=TZ(I,JV)+FZ(I,JV)              tz(i, jv) = tz(i, jv) + fz(i, jv)
361  C  
362           ENDIF            END IF
363  C  
364   1700 CONTINUE          END DO
365   170  CONTINUE        END DO
366  C  
367        DO 171 JV=1,NTRA        DO jv = 1, ntra
368        DO 1710 I=1,LONK-1          DO i = 1, lonk - 1
369  C  
370           IF(UEXT(I).GE.0.) THEN            IF (uext(i)>=0.) THEN
371  C  
372             TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)              temptm = alf(i)*t0(i+1, jv) - alf1(i)*f0(i, jv)
373             T0(I+1,JV)=T0(I+1,JV)+F0(I,JV)              t0(i+1, jv) = t0(i+1, jv) + f0(i, jv)
374             TX(I+1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I+1,JV)+3.*TEMPTM              tx(i+1, jv) = alf(i)*fx(i, jv) + alf1(i)*tx(i+1, jv) + 3.*temptm
375             TY(I+1,JV)=TY(I+1,JV)+FY(I,JV)              ty(i+1, jv) = ty(i+1, jv) + fy(i, jv)
376             TZ(I+1,JV)=TZ(I+1,JV)+FZ(I,JV)              tz(i+1, jv) = tz(i+1, jv) + fz(i, jv)
377  C  
378           ENDIF            END IF
379  C  
380   1710 CONTINUE          END DO
381   171  CONTINUE        END DO
382  C  
383        I=LONK        i = lonk
384        IF(UEXT(I).GE.0.) THEN        IF (uext(i)>=0.) THEN
385          DO 172 JV=1,NTRA          DO jv = 1, ntra
386             TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)            temptm = alf(i)*t0(1, jv) - alf1(i)*f0(i, jv)
387             T0(1,JV)=T0(1,JV)+F0(I,JV)            t0(1, jv) = t0(1, jv) + f0(i, jv)
388             TX(1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM            tx(1, jv) = alf(i)*fx(i, jv) + alf1(i)*tx(1, jv) + 3.*temptm
389             TY(1,JV)=TY(1,JV)+FY(I,JV)            ty(1, jv) = ty(1, jv) + fy(i, jv)
390             TZ(1,JV)=TZ(1,JV)+FZ(I,JV)            tz(1, jv) = tz(1, jv) + fz(i, jv)
391   172    CONTINUE          END DO
392        ENDIF        END IF
393  C  
394  C  retour aux mailles d'origine (passage des Tij aux Sij)        ! retour aux mailles d'origine (passage des Tij aux Sij)
395  C  
396        IF(NUMK.GT.1) THEN        IF (numk>1) THEN
397  C  
398        DO 180 I2=1,NUMK          DO i2 = 1, numk
399  C  
400           DO 180 I=1,LONK            DO i = 1, lonk
401  C  
402              I3=I2+(I-1)*NUMK              i3 = i2 + (i-1)*numk
403              SM(I3,K,L)=SMNEW(I3)              sm(i3, k, l) = smnew(i3)
404              ALF(I)=SMNEW(I3)/TM(I)              alf(i) = smnew(i3)/tm(i)
405              TM(I)=TM(I)-SMNEW(I3)              tm(i) = tm(i) - smnew(i3)
406  C  
407              ALFQ(I)=ALF(I)*ALF(I)              alfq(i) = alf(i)*alf(i)
408              ALF1(I)=1.-ALF(I)              alf1(i) = 1. - alf(i)
409              ALF1Q(I)=ALF1(I)*ALF1(I)              alf1q(i) = alf1(i)*alf1(i)
410  C  
411   180     CONTINUE            END DO
412  C          END DO
413           DO  JV=1,NTRA  
414           DO  I=1,LONK          DO jv = 1, ntra
415  C            DO i = 1, lonk
416              I3=I2+(I-1)*NUMK  
417              S0(I3,K,L,JV)=ALF (I)              i3 = i2 + (i-1)*numk
418       $       * (T0(I,JV)-ALF1(I)*TX(I,JV))              s0(i3, k, l, jv) = alf(i)*(t0(i,jv)-alf1(i)*tx(i,jv))
419              sx(I3,K,L,JV)=ALFQ(I)*TX(I,JV)              sx(i3, k, l, jv) = alfq(i)*tx(i, jv)
420              sy(I3,K,L,JV)=ALF (I)*TY(I,JV)              sy(i3, k, l, jv) = alf(i)*ty(i, jv)
421              sz(I3,K,L,JV)=ALF (I)*TZ(I,JV)              sz(i3, k, l, jv) = alf(i)*tz(i, jv)
422  C  
423  C   reajusts moments remaining in the box              ! reajusts moments remaining in the box
424  C  
425              T0(I,JV)=T0(I,JV)-S0(I3,K,L,JV)              t0(i, jv) = t0(i, jv) - s0(i3, k, l, jv)
426              TX(I,JV)=ALF1Q(I)*TX(I,JV)              tx(i, jv) = alf1q(i)*tx(i, jv)
427              TY(I,JV)=TY(I,JV)-sy(I3,K,L,JV)              ty(i, jv) = ty(i, jv) - sy(i3, k, l, jv)
428              TZ(I,JV)=TZ(I,JV)-sz(I3,K,L,JV)              tz(i, jv) = tz(i, jv) - sz(i3, k, l, jv)
429            ENDDO            END DO
430            ENDDO          END DO
431  C  
432  C  
433        ELSE        ELSE
434  C  
435        DO 190 I=1,LON          DO i = 1, lon
436           SM(I,K,L)=TM(I)            sm(i, k, l) = tm(i)
437   190  CONTINUE          END DO
438        DO 191 JV=1,NTRA          DO jv = 1, ntra
439        DO 1910 I=1,LON            DO i = 1, lon
440           S0(I,K,L,JV)=T0(I,JV)              s0(i, k, l, jv) = t0(i, jv)
441           sx(I,K,L,JV)=TX(I,JV)              sx(i, k, l, jv) = tx(i, jv)
442           sy(I,K,L,JV)=TY(I,JV)              sy(i, k, l, jv) = ty(i, jv)
443           sz(I,K,L,JV)=TZ(I,JV)              sz(i, k, l, jv) = tz(i, jv)
444   1910 CONTINUE            END DO
445   191  CONTINUE          END DO
446  C  
447        ENDIF        END IF
448  C  
449   1    CONTINUE      END DO
450  C    END DO
451  C ---------- bouclage cyclique  
452        DO itrac=1,ntra    ! ---------- bouclage cyclique
453        DO l = 1,llm    DO itrac = 1, ntra
454          DO j = lati,latf      DO l = 1, llm
455             SM(iip1,j,l) = SM(1,j,l)        DO j = lati, latf
456             S0(iip1,j,l,itrac) = S0(1,j,l,itrac)          sm(iip1, j, l) = sm(1, j, l)
457             sx(iip1,j,l,itrac) = sx(1,j,l,itrac)          s0(iip1, j, l, itrac) = s0(1, j, l, itrac)
458             sy(iip1,j,l,itrac) = sy(1,j,l,itrac)          sx(iip1, j, l, itrac) = sx(1, j, l, itrac)
459             sz(iip1,j,l,itrac) = sz(1,j,l,itrac)          sy(iip1, j, l, itrac) = sy(1, j, l, itrac)
460          END DO          sz(iip1, j, l, itrac) = sz(1, j, l, itrac)
461        END DO        END DO
462        ENDDO      END DO
463      END DO
464  c ----------- qqtite totale de traceur dans tte l'atmosphere  
465        DO l = 1, llm    ! ----------- qqtite totale de traceur dans tte l'atmosphere
466          DO j = 1, jjp1    DO l = 1, llm
467            DO i = 1, iim      DO j = 1, jjp1
468  cIM 240405          sqf = sqf + S0(i,j,l,9)        DO i = 1, iim
469               sqf = sqf + S0(i,j,l,ntra)          ! IM 240405          sqf = sqf + S0(i,j,l,9)
470            END DO            sqf = sqf + s0(i, j, l, ntra)
471          END DO        END DO
472        END DO      END DO
473  c    END DO
474        PRINT*,'------ DIAG DANS ADVX - SORTIE -----'  
475        PRINT*,'sqf=',sqf    PRINT *, '------ DIAG DANS ADVX - SORTIE -----'
476  c-------------    PRINT *, 'sqf=', sqf
477      ! -------------
478        RETURN  
479        END    RETURN
480  C_________________________________________________________________  END SUBROUTINE advx
481  C_________________________________________________________________  ! _________________________________________________________________
482    ! _________________________________________________________________
Legend:
Removed from v.80  
changed lines
  Added in v.81
  ViewVC Help
Powered by ViewVC 1.1.21