--- trunk/dyn3d/advxp.f 2014/03/05 12:22:46 80 +++ trunk/dyn3d/advxp.f90 2014/03/05 14:38:41 81 @@ -1,619 +1,619 @@ -! -! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/advxp.F,v 1.1.1.1 2004/05/19 12:53:06 lmdzadmin Exp $ -! - SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ - . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra) - use dimens_m - use paramet_m - use comconst - use disvert_m - IMPLICIT NONE -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C second-order moments (SOM) advection of tracer in X direction C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C parametres principaux du modele -C - - INTEGER ntra -c PARAMETER (ntra = 1) -C -C definition de la grille du modele -C - REAL dtx - REAL, intent(in):: pbaru ( iip1,jjp1,llm ) -C -C moments: SM total mass in each grid box -C S0 mass of tracer in each grid box -C Si 1rst order moment in i direction -C Sij 2nd order moment in i and j directions -C - REAL SM(iip1,jjp1,llm) - + ,S0(iip1,jjp1,llm,ntra) - REAL SSX(iip1,jjp1,llm,ntra) - + ,SY(iip1,jjp1,llm,ntra) - + ,SZ(iip1,jjp1,llm,ntra) - REAL SSXX(iip1,jjp1,llm,ntra) - + ,SSXY(iip1,jjp1,llm,ntra) - + ,SSXZ(iip1,jjp1,llm,ntra) - + ,SYY(iip1,jjp1,llm,ntra) - + ,SYZ(iip1,jjp1,llm,ntra) - + ,SZZ(iip1,jjp1,llm,ntra) - -C Local : -C ------- - -C mass fluxes across the boundaries (UGRI,VGRI,WGRI) -C mass fluxes in kg -C declaration : - - REAL UGRI(iip1,jjp1,llm) - -C Rem : VGRI et WGRI ne sont pas utilises dans -C cette subroutine ( advection en x uniquement ) -C -C -C Tij are the moments for the current latitude and level -C - REAL TM (iim) - REAL T0 (iim,NTRA),TX (iim,NTRA) - REAL TY (iim,NTRA),TZ (iim,NTRA) - REAL TXX(iim,NTRA),TXY(iim,NTRA) - REAL TXZ(iim,NTRA),TYY(iim,NTRA) - REAL TYZ(iim,NTRA),TZZ(iim,NTRA) -C -C the moments F are similarly defined and used as temporary -C storage for portions of the grid boxes in transit -C - REAL FM (iim) - REAL F0 (iim,NTRA),FX (iim,NTRA) - REAL FY (iim,NTRA),FZ (iim,NTRA) - REAL FXX(iim,NTRA),FXY(iim,NTRA) - REAL FXZ(iim,NTRA),FYY(iim,NTRA) - REAL FYZ(iim,NTRA),FZZ(iim,NTRA) -C -C work arrays -C - REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) - REAL ALF2(iim),ALF3(iim),ALF4(iim) -C - REAL SMNEW(iim),UEXT(iim) - REAL sqi,sqf - REAL TEMPTM - REAL SLPMAX - REAL S1MAX,S1NEW,S2NEW - - LOGICAL LIMIT - INTEGER NUM(jjp1),LONK,NUMK - INTEGER lon,lati,latf,niv - INTEGER i,i2,i3,j,jv,l,k,iter - - lon = iim - lati=2 - latf = jjm - niv = llm - -C *** Test : diagnostique de la qtite totale de traceur -C dans l'atmosphere avant l'advection -c - sqi =0. - sqf =0. -c - DO l = 1, llm - DO j = 1, jjp1 + +! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/advxp.F,v 1.1.1.1 2004/05/19 +! 12:53:06 lmdzadmin Exp $ + +SUBROUTINE advxp(limit, dtx, pbaru, sm, s0, ssx, sy, sz, ssxx, ssxy, ssxz, & + syy, syz, szz, ntra) + USE dimens_m + USE paramet_m + USE comconst + USE disvert_m + IMPLICIT NONE + ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + ! C + ! second-order moments (SOM) advection of tracer in X direction C + ! C + ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + ! parametres principaux du modele + + + INTEGER ntra + ! PARAMETER (ntra = 1) + + ! definition de la grille du modele + + REAL dtx + REAL, INTENT (IN) :: pbaru(iip1, jjp1, llm) + + ! moments: SM total mass in each grid box + ! S0 mass of tracer in each grid box + ! Si 1rst order moment in i direction + ! Sij 2nd order moment in i and j directions + + REAL sm(iip1, jjp1, llm), s0(iip1, jjp1, llm, ntra) + REAL ssx(iip1, jjp1, llm, ntra), sy(iip1, jjp1, llm, ntra), & + sz(iip1, jjp1, llm, ntra) + REAL ssxx(iip1, jjp1, llm, ntra), ssxy(iip1, jjp1, llm, ntra), & + ssxz(iip1, jjp1, llm, ntra), syy(iip1, jjp1, llm, ntra), & + syz(iip1, jjp1, llm, ntra), szz(iip1, jjp1, llm, ntra) + + ! Local : + ! ------- + + ! mass fluxes across the boundaries (UGRI,VGRI,WGRI) + ! mass fluxes in kg + ! declaration : + + REAL ugri(iip1, jjp1, llm) + + ! Rem : VGRI et WGRI ne sont pas utilises dans + ! cette subroutine ( advection en x uniquement ) + + + ! Tij are the moments for the current latitude and level + + REAL tm(iim) + REAL t0(iim, ntra), tx(iim, ntra) + REAL ty(iim, ntra), tz(iim, ntra) + REAL txx(iim, ntra), txy(iim, ntra) + REAL txz(iim, ntra), tyy(iim, ntra) + REAL tyz(iim, ntra), tzz(iim, ntra) + + ! the moments F are similarly defined and used as temporary + ! storage for portions of the grid boxes in transit + + REAL fm(iim) + REAL f0(iim, ntra), fx(iim, ntra) + REAL fy(iim, ntra), fz(iim, ntra) + REAL fxx(iim, ntra), fxy(iim, ntra) + REAL fxz(iim, ntra), fyy(iim, ntra) + REAL fyz(iim, ntra), fzz(iim, ntra) + + ! work arrays + + REAL alf(iim), alf1(iim), alfq(iim), alf1q(iim) + REAL alf2(iim), alf3(iim), alf4(iim) + + REAL smnew(iim), uext(iim) + REAL sqi, sqf + REAL temptm + REAL slpmax + REAL s1max, s1new, s2new + + LOGICAL limit + INTEGER num(jjp1), lonk, numk + INTEGER lon, lati, latf, niv + INTEGER i, i2, i3, j, jv, l, k, iter + + lon = iim + lati = 2 + latf = jjm + niv = llm + + ! *** Test : diagnostique de la qtite totale de traceur + ! dans l'atmosphere avant l'advection + + sqi = 0. + sqf = 0. + + DO l = 1, llm + DO j = 1, jjp1 DO i = 1, iim - sqi = sqi + S0(i,j,l,ntra) + sqi = sqi + s0(i, j, l, ntra) END DO + END DO + END DO + PRINT *, '------ DIAG DANS ADVX2 - ENTREE -----' + PRINT *, 'sqi=', sqi + ! test + ! ------------------------------------- + DO j = 1, jjp1 + num(j) = 1 + END DO + ! DO l=1,llm + ! NUM(2,l)=6 + ! NUM(3,l)=6 + ! NUM(jjm-1,l)=6 + ! NUM(jjm,l)=6 + ! ENDDO + ! DO j=2,6 + ! NUM(j)=12 + ! ENDDO + ! DO j=jjm-5,jjm-1 + ! NUM(j)=12 + ! ENDDO + + ! Interface : adaptation nouveau modele + ! ------------------------------------- + + ! --------------------------------------------------------- + ! Conversion des flux de masses en kg/s + ! pbaru est en N/s d'ou : + ! ugri est en kg/s + + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iip1 + ugri(i, j, llm+1-l) = pbaru(i, j, l) END DO + END DO + END DO + + ! --------------------------------------------------------- + ! start here + + ! boucle principale sur les niveaux et les latitudes + + DO l = 1, niv + DO k = lati, latf + + + ! initialisation + + ! program assumes periodic boundaries in X + + DO i = 2, lon + smnew(i) = sm(i, k, l) + (ugri(i-1,k,l)-ugri(i,k,l))*dtx END DO - PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----' - PRINT*,'sqi=',sqi -c test -c ------------------------------------- - DO 300 j =1,jjp1 - NUM(j) =1 - 300 CONTINUE -c DO l=1,llm -c NUM(2,l)=6 -c NUM(3,l)=6 -c NUM(jjm-1,l)=6 -c NUM(jjm,l)=6 -c ENDDO -c DO j=2,6 -c NUM(j)=12 -c ENDDO -c DO j=jjm-5,jjm-1 -c NUM(j)=12 -c ENDDO - -C Interface : adaptation nouveau modele -C ------------------------------------- -C -C --------------------------------------------------------- -C Conversion des flux de masses en kg/s -C pbaru est en N/s d'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 CONTINUE - -C --------------------------------------------------------- -C start here -C -C boucle principale sur les niveaux et les latitudes -C - DO 1 L=1,NIV - DO 1 K=lati,latf - -C -C initialisation -C -C program assumes periodic boundaries in X -C - 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))*DTX -C -C modifications for extended polar zones -C - NUMK=NUM(K) - LONK=LON/NUMK -C - IF(NUMK.GT.1) THEN -C - 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 CONTINUE -C - DO 11 I2=1,NUMK -C - 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 CONTINUE -C - 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 CONTINUE -C - 11 CONTINUE -C - ELSE -C - 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 CONTINUE -C - ENDIF -C - DO 117 I=1,LONK - UEXT(I)=UGRI(I*NUMK,K,L) - 117 CONTINUE -C -C place limits on appropriate moments before transport -C (if flux-limiting is to be applied) -C - IF(.NOT.LIMIT) GO TO 13 -C - DO 12 JV=1,NTRA - DO 120 I=1,LONK - IF(T0(I,JV).GT.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 CONTINUE -C - 13 CONTINUE -C -C calculate flux and moments between adjacent boxes -C 1- create temporary moments/masses for partial boxes in transit -C 2- reajusts moments remaining in the box -C -C flux from IP to I if U(I).lt.0 -C - DO 140 I=1,LONK-1 - IF(UEXT(I).LT.0.) THEN - FM(I)=-UEXT(I)*DTX - ALF(I)=FM(I)/TM(I+1) - TM(I+1)=TM(I+1)-FM(I) - ENDIF - 140 CONTINUE -C - I=LONK - IF(UEXT(I).LT.0.) THEN - FM(I)=-UEXT(I)*DTX - ALF(I)=FM(I)/TM(1) - TM(1)=TM(1)-FM(I) - ENDIF -C -C flux from I to IP if U(I).gt.0 -C - DO 141 I=1,LONK - IF(UEXT(I).GE.0.) THEN - FM(I)=UEXT(I)*DTX - ALF(I)=FM(I)/TM(I) - TM(I)=TM(I)-FM(I) - ENDIF - 141 CONTINUE -C - 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 CONTINUE -C - DO 150 JV=1,NTRA - DO 1500 I=1,LONK-1 -C - IF(UEXT(I).LT.0.) THEN -C - 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 - ENDIF -C - 1500 CONTINUE - 150 CONTINUE -C - I=LONK - IF(UEXT(I).LT.0.) THEN -C - DO 151 JV=1,NTRA -C - 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 CONTINUE -C - ENDIF -C - DO 152 JV=1,NTRA - DO 1520 I=1,LONK -C - IF(UEXT(I).GE.0.) THEN -C - 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 - ENDIF -C - 1520 CONTINUE - 152 CONTINUE -C -C puts the temporary moments Fi into appropriate neighboring boxes -C - DO 160 I=1,LONK - IF(UEXT(I).LT.0.) THEN - TM(I)=TM(I)+FM(I) - ALF(I)=FM(I)/TM(I) - ENDIF - 160 CONTINUE -C - DO 161 I=1,LONK-1 - IF(UEXT(I).GE.0.) THEN - TM(I+1)=TM(I+1)+FM(I) - ALF(I)=FM(I)/TM(I+1) - ENDIF - 161 CONTINUE -C - I=LONK - IF(UEXT(I).GE.0.) THEN - TM(1)=TM(1)+FM(I) - ALF(I)=FM(I)/TM(1) - ENDIF -C - 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 CONTINUE -C - DO 170 JV=1,NTRA - DO 1700 I=1,LONK -C - IF(UEXT(I).LT.0.) THEN -C - 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 - ENDIF -C - 1700 CONTINUE - 170 CONTINUE -C - DO 171 JV=1,NTRA - DO 1710 I=1,LONK-1 -C - IF(UEXT(I).GE.0.) THEN -C - 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 - ENDIF -C - 1710 CONTINUE - 171 CONTINUE -C - I=LONK - IF(UEXT(I).GE.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 - ENDIF -C -C retour aux mailles d'origine (passage des Tij aux Sij) -C - IF(NUMK.GT.1) THEN -C - DO 18 I2=1,NUMK -C - DO 180 I=1,LONK -C - I3=I2+(I-1)*NUMK - SM(I3,K,L)=SMNEW(I3) - ALF(I)=SMNEW(I3)/TM(I) - TM(I)=TM(I)-SMNEW(I3) -C - 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) -C - 180 CONTINUE -C - DO 181 JV=1,NTRA - DO 181 I=1,LONK -C - I3=I2+(I-1)*NUMK - S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)* - + ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) ) - SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV)) - SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV) - SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV)) - SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV)) - SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV) - SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV) - SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV) - SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV) - SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV) -C -C reajusts moments remaining in the box -C - T0 (I,JV)=T0(I,JV)-S0(I3,K,L,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)-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) - TXY(I,JV)=ALF1Q(I)*TXY(I,JV) - TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) -C - 181 CONTINUE -C - 18 CONTINUE -C + smnew(1) = sm(1, k, l) + (ugri(lon,k,l)-ugri(1,k,l))*dtx + + ! modifications for extended polar zones + + numk = num(k) + lonk = lon/numk + + IF (numk>1) THEN + + DO i = 1, lon + tm(i) = 0. + END DO + DO jv = 1, ntra + DO 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. + END DO + END DO + + DO i2 = 1, numk + + DO 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) + END DO + + DO jv = 1, ntra + DO 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) + END DO + END DO + + END DO + ELSE -C - DO 190 I=1,LON - SM(I,K,L)=TM(I) - 190 CONTINUE - DO 191 JV=1,NTRA - DO 1910 I=1,LON - S0 (I,K,L,JV)=T0 (I,JV) - SSX (I,K,L,JV)=TX (I,JV) - SY (I,K,L,JV)=TY (I,JV) - SZ (I,K,L,JV)=TZ (I,JV) - SSXX(I,K,L,JV)=TXX(I,JV) - SSXY(I,K,L,JV)=TXY(I,JV) - SSXZ(I,K,L,JV)=TXZ(I,JV) - SYY(I,K,L,JV)=TYY(I,JV) - SYZ(I,K,L,JV)=TYZ(I,JV) - SZZ(I,K,L,JV)=TZZ(I,JV) - 1910 CONTINUE - 191 CONTINUE -C - ENDIF -C - 1 CONTINUE - -c ---------- bouclage cyclique - - DO l = 1,llm - DO j = 1,jjp1 - SM(iip1,j,l) = SM(1,j,l) - S0(iip1,j,l,ntra) = S0(1,j,l,ntra) - SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) - SY(iip1,j,l,ntra) = SY(1,j,l,ntra) - SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) + + DO i = 1, lon + tm(i) = sm(i, k, l) + END DO + DO jv = 1, ntra + DO 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) + END DO + END DO + + END IF + + DO i = 1, lonk + uext(i) = ugri(i*numk, k, l) END DO + + ! place limits on appropriate moments before transport + ! (if flux-limiting is to be applied) + + IF (.NOT. limit) GO TO 13 + + DO jv = 1, ntra + DO 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. + END IF + END DO END DO -C ----------- qqtite totale de traceur dans tte l'atmosphere - DO l = 1, llm - DO j = 1, jjp1 - DO i = 1, iim - sqf = sqf + S0(i,j,l,ntra) +13 CONTINUE + + ! calculate flux and moments between adjacent boxes + ! 1- create temporary moments/masses for partial boxes in transit + ! 2- reajusts moments remaining in the box + + ! flux from IP to I if U(I).lt.0 + + DO 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) + END IF + END DO + + i = lonk + IF (uext(i)<0.) THEN + fm(i) = -uext(i)*dtx + alf(i) = fm(i)/tm(1) + tm(1) = tm(1) - fm(i) + END IF + + ! flux from I to IP if U(I).gt.0 + + DO 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) + END IF + END DO + + DO 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) + END DO + + DO jv = 1, ntra + DO i = 1, lonk - 1 + + IF (uext(i)<0.) THEN + + 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) + + 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) + + END IF + + END DO + END DO + + i = lonk + IF (uext(i)<0.) THEN + + DO jv = 1, ntra + + 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) + + 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) + + END DO + + END IF + + DO jv = 1, ntra + DO i = 1, lonk + + IF (uext(i)>=0.) THEN + + 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) + + 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) + + END IF + + END DO + END DO + + ! puts the temporary moments Fi into appropriate neighboring boxes + + DO i = 1, lonk + IF (uext(i)<0.) THEN + tm(i) = tm(i) + fm(i) + alf(i) = fm(i)/tm(i) + END IF + END DO + + DO i = 1, lonk - 1 + IF (uext(i)>=0.) THEN + tm(i+1) = tm(i+1) + fm(i) + alf(i) = fm(i)/tm(i+1) + END IF + END DO + + i = lonk + IF (uext(i)>=0.) THEN + tm(1) = tm(1) + fm(i) + alf(i) = fm(i)/tm(1) + END IF + + DO 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) + END DO + + DO jv = 1, ntra + DO i = 1, lonk + + IF (uext(i)<0.) THEN + + 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) + + END IF + + END DO END DO + + DO jv = 1, ntra + DO i = 1, lonk - 1 + + IF (uext(i)>=0.) THEN + + 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) + + END IF + + END DO END DO + + i = lonk + IF (uext(i)>=0.) THEN + DO 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) + END DO + END IF + + ! retour aux mailles d'origine (passage des Tij aux Sij) + + IF (numk>1) THEN + + DO i2 = 1, numk + + DO i = 1, lonk + + i3 = i2 + (i-1)*numk + sm(i3, k, l) = smnew(i3) + alf(i) = smnew(i3)/tm(i) + tm(i) = tm(i) - smnew(i3) + + 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) + + END DO + + DO jv = 1, ntra + DO i = 1, lonk + + i3 = i2 + (i-1)*numk + s0(i3, k, l, jv) = alf(i)*(t0(i,jv)-alf1(i)*(tx(i, & + jv)-alf2(i)*txx(i,jv))) + ssx(i3, k, l, jv) = alfq(i)*(tx(i,jv)-3.*alf1(i)*txx(i,jv)) + ssxx(i3, k, l, jv) = alf3(i)*txx(i, jv) + sy(i3, k, l, jv) = alf(i)*(ty(i,jv)-alf1(i)*txy(i,jv)) + sz(i3, k, l, jv) = alf(i)*(tz(i,jv)-alf1(i)*txz(i,jv)) + ssxy(i3, k, l, jv) = alfq(i)*txy(i, jv) + ssxz(i3, k, l, jv) = alfq(i)*txz(i, jv) + syy(i3, k, l, jv) = alf(i)*tyy(i, jv) + syz(i3, k, l, jv) = alf(i)*tyz(i, jv) + szz(i3, k, l, jv) = alf(i)*tzz(i, jv) + + ! reajusts moments remaining in the box + + t0(i, jv) = t0(i, jv) - s0(i3, k, l, 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) - 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) + txy(i, jv) = alf1q(i)*txy(i, jv) + txz(i, jv) = alf1q(i)*txz(i, jv) + + END DO + END DO + + END DO + + ELSE + + DO i = 1, lon + sm(i, k, l) = tm(i) + END DO + DO jv = 1, ntra + DO i = 1, lon + s0(i, k, l, jv) = t0(i, jv) + ssx(i, k, l, jv) = tx(i, jv) + sy(i, k, l, jv) = ty(i, jv) + sz(i, k, l, jv) = tz(i, jv) + ssxx(i, k, l, jv) = txx(i, jv) + ssxy(i, k, l, jv) = txy(i, jv) + ssxz(i, k, l, jv) = txz(i, jv) + syy(i, k, l, jv) = tyy(i, jv) + syz(i, k, l, jv) = tyz(i, jv) + szz(i, k, l, jv) = tzz(i, jv) + END DO + END DO + + END IF + + END DO + END DO + + ! ---------- bouclage cyclique + + DO l = 1, llm + DO j = 1, jjp1 + sm(iip1, j, l) = sm(1, j, l) + s0(iip1, j, l, ntra) = s0(1, j, l, ntra) + ssx(iip1, j, l, ntra) = ssx(1, j, l, ntra) + sy(iip1, j, l, ntra) = sy(1, j, l, ntra) + sz(iip1, j, l, ntra) = sz(1, j, l, ntra) + END DO + END DO + + ! ----------- qqtite totale de traceur dans tte l'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 -----' - PRINT*,'sqf=',sqf -c------------------------------------------------------------- - RETURN - END + PRINT *, '------ DIAG DANS ADVX2 - SORTIE -----' + PRINT *, 'sqf=', sqf + ! ------------------------------------------------------------- + RETURN +END SUBROUTINE advxp