/[lmdze]/trunk/Sources/dyn3d/advy.f
ViewVC logotype

Diff of /trunk/Sources/dyn3d/advy.f

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

trunk/libf/dyn3d/advy.f revision 66 by guez, Thu Sep 20 13:00:41 2012 UTC trunk/dyn3d/advy.f revision 112 by guez, Thu Sep 18 13:36:51 2014 UTC
# Line 1  Line 1 
1  !  
2  ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/advy.F,v 1.1.1.1 2004/05/19 12:53:06 lmdzadmin Exp $  ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/advy.F,v 1.1.1.1 2004/05/19
3  !  ! 12:53:06 lmdzadmin Exp $
4        SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz)  
5        use dimens_m  SUBROUTINE advy(limit, dty, pbarv, sm, s0, sx, sy, sz)
6        use paramet_m    USE dimens_m
7        use comconst    USE paramet_m
8        use disvert_m    USE comconst
9        use comgeom    USE disvert_m
10        IMPLICIT NONE    USE comgeom
11      IMPLICIT NONE
12  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC  
13  C                                                                C    ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
14  C  first-order moments (SOM) advection of tracer in Y direction  C    ! C
15  C                                                                C    ! first-order moments (SOM) advection of tracer in Y direction  C
16  C  Source : Pascal Simon ( Meteo, CNRM )                         C    ! C
17  C  Adaptation : A.A. (LGGE)                                      C    ! Source : Pascal Simon ( Meteo, CNRM )                        C
18  C  Derniere Modif : 15/12/94 LAST    ! Adaptation : A.A. (LGGE)                                     C
19  C                                                                C    ! Derniere Modif : 15/12/94 LAST
20  C  sont les arguments d'entree pour le s-pg                      C    ! C
21  C                                                                C    ! sont les arguments d'entree pour le s-pg                     C
22  C  argument de sortie du s-pg                                    C    ! C
23  C                                                                C    ! argument de sortie du s-pg                                   C
24  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC    ! C
25  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC    ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26  C    ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
27  C  Rem : Probleme aux poles il faut reecrire ce cas specifique  
28  C        Attention au sens de l'indexation    ! Rem : Probleme aux poles il faut reecrire ce cas specifique
29  C    ! Attention au sens de l'indexation
30  C  parametres principaux du modele  
31  C    ! parametres principaux du modele
32  C  
33    
34  C  Arguments :  
35  C  ----------    ! Arguments :
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    ! dty : frequence fictive d'appel du transport
38      ! parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
39        INTEGER lon,lat,niv  
40        INTEGER i,j,jv,k,kp,l    INTEGER lon, lat, niv
41        INTEGER ntra    INTEGER i, j, jv, k, kp, l
42        PARAMETER (ntra = 1)    INTEGER ntra
43      PARAMETER (ntra=1)
44        REAL dty  
45        REAL, intent(in):: pbarv ( iip1,jjm, llm )    REAL dty
46      REAL, INTENT (IN) :: pbarv(iip1, jjm, llm)
47  C  moments: SM  total mass in each grid box  
48  C           S0  mass of tracer in each grid box    ! moments: SM  total mass in each grid box
49  C           Si  1rst order moment in i direction    ! S0  mass of tracer in each grid box
50  C    ! Si  1rst order moment in i direction
51        REAL SM(iip1,jjp1,llm)  
52       +    ,S0(iip1,jjp1,llm,ntra)    REAL sm(iip1, jjp1, llm), s0(iip1, jjp1, llm, ntra)
53        REAL sx(iip1,jjp1,llm,ntra)    REAL sx(iip1, jjp1, llm, ntra), sy(iip1, jjp1, llm, ntra), &
54       +    ,sy(iip1,jjp1,llm,ntra)      sz(iip1, jjp1, llm, ntra)
55       +    ,sz(iip1,jjp1,llm,ntra)  
56    
57      ! Local :
58  C  Local :    ! -------
59  C  -------  
60      ! mass fluxes across the boundaries (UGRI,VGRI,WGRI)
61  C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)    ! mass fluxes in kg
62  C  mass fluxes in kg    ! declaration :
63  C  declaration :  
64      REAL vgri(iip1, 0:jjp1, llm)
65        REAL VGRI(iip1,0:jjp1,llm)  
66      ! Rem : UGRI et WGRI ne sont pas utilises dans
67  C  Rem : UGRI et WGRI ne sont pas utilises dans    ! cette subroutine ( advection en y uniquement )
68  C  cette subroutine ( advection en y uniquement )    ! Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
69  C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv  
70  C    ! the moments F are similarly defined and used as temporary
71  C  the moments F are similarly defined and used as temporary    ! storage for portions of the grid boxes in transit
72  C  storage for portions of the grid boxes in transit  
73  C    REAL f0(iim, 0:jjp1, ntra), fm(iim, 0:jjp1)
74        REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)    REAL fx(iim, jjm, ntra), fy(iim, jjm, ntra)
75        REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)    REAL fz(iim, jjm, ntra)
76        REAL FZ(iim,jjm,ntra)    REAL s00(ntra)
77        REAL S00(ntra)    REAL sm0 ! Just temporal variable
78        REAL SM0             ! Just temporal variable  
79  C    ! work arrays
80  C  work arrays  
81  C    REAL alf(iim, 0:jjp1), alf1(iim, 0:jjp1)
82        REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)    REAL alfq(iim, 0:jjp1), alf1q(iim, 0:jjp1)
83        REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)    REAL temptm ! Just temporal variable
84        REAL TEMPTM          ! Just temporal variable  
85  c    ! Special pour poles
86  C  Special pour poles  
87  c    REAL ssum
88        REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn    EXTERNAL ssum
89        REAL sns0(ntra),snsz(ntra),snsm  
90        REAL s1v(llm),slatv(llm)    LOGICAL limit
91        REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)  
92        REAL cx1(llm,ntra), cxLAT(llm,ntra)    lon = iim ! rem : Il est possible qu'un pbl. arrive ici
93        REAL cy1(llm,ntra), cyLAT(llm,ntra)    lat = jjp1 ! a cause des dim. differentes entre les
94        REAL z1(iim), zcos(iim), zsin(iim)    niv = llm
95        real smpn,smps,s0pn,s0ps  
96        REAL SSUM  
97        EXTERNAL SSUM    ! the moments Fi are used as temporary storage for
98  C    ! portions of the grid boxes in transit at the current level
99        REAL sqi,sqf  
100        LOGICAL LIMIT    ! work arrays
101    
102        lon = iim         ! rem : Il est possible qu'un pbl. arrive ici  
103        lat = jjp1        ! a cause des dim. differentes entre les    DO l = 1, llm
104        niv=llm      DO j = 1, jjm
105          DO i = 1, iip1
106  C          vgri(i, j, llm+1-l) = -1.*pbarv(i, j, l)
107  C  the moments Fi are used as temporary storage for        END DO
108  C  portions of the grid boxes in transit at the current level      END DO
109  C      DO i = 1, iip1
110  C  work arrays        vgri(i, 0, l) = 0.
111  C        vgri(i, jjp1, l) = 0.
112        END DO
113        DO l = 1,llm    END DO
114           DO j = 1,jjm  
115              DO i = 1,iip1      DO l = 1, niv
116              vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l)    
117              enddo      ! place limits on appropriate moments before transport
118           enddo      ! (if flux-limiting is to be applied)
119           do i=1,iip1  
120               vgri(i,0,l) = 0.      IF (.NOT. limit) GO TO 11
121               vgri(i,jjp1,l) = 0.  
122           enddo      DO jv = 1, ntra
123        enddo        DO k = 1, lat
124            DO i = 1, lon
125        DO 1 L=1,NIV            sy(i, k, l, jv) = sign(amin1(amax1(s0(i,k,l,jv), &
126  C              0.),abs(sy(i,k,l,jv))), sy(i,k,l,jv))
127  C  place limits on appropriate moments before transport          END DO
128  C      (if flux-limiting is to be applied)        END DO
129  C      END DO
130        IF(.NOT.LIMIT) GO TO 11  
131  C  11  CONTINUE
132        DO 10 JV=1,NTRA  
133        DO 10 K=1,LAT      ! le flux a travers le pole Nord est traite separement
134        DO 100 I=1,LON  
135           sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),      sm0 = 0.
136       +                           ABS(sy(I,K,L,JV))),sy(I,K,L,JV))      DO jv = 1, ntra
137   100  CONTINUE        s00(jv) = 0.
138   10   CONTINUE      END DO
139  C  
140   11   CONTINUE      DO i = 1, lon
141  C  
142  C  le flux a travers le pole Nord est traite separement        IF (vgri(i,0,l)<=0.) THEN
143  C          fm(i, 0) = -vgri(i, 0, l)*dty
144        SM0=0.          alf(i, 0) = fm(i, 0)/sm(i, 1, l)
145        DO 20 JV=1,NTRA          sm(i, 1, l) = sm(i, 1, l) - fm(i, 0)
146           S00(JV)=0.          sm0 = sm0 + fm(i, 0)
147   20   CONTINUE        END IF
148  C  
149        DO 21 I=1,LON        alfq(i, 0) = alf(i, 0)*alf(i, 0)
150  C        alf1(i, 0) = 1. - alf(i, 0)
151           IF(VGRI(I,0,L).LE.0.) THEN        alf1q(i, 0) = alf1(i, 0)*alf1(i, 0)
152             FM(I,0)=-VGRI(I,0,L)*DTY  
153             ALF(I,0)=FM(I,0)/SM(I,1,L)      END DO
154             SM(I,1,L)=SM(I,1,L)-FM(I,0)  
155             SM0=SM0+FM(I,0)      DO jv = 1, ntra
156           ENDIF        DO i = 1, lon
157  C  
158           ALFQ(I,0)=ALF(I,0)*ALF(I,0)          IF (vgri(i,0,l)<=0.) THEN
159           ALF1(I,0)=1.-ALF(I,0)  
160           ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)            f0(i, 0, jv) = alf(i, 0)*(s0(i,1,l,jv)-alf1(i,0)*sy(i,1,l,jv))
161  C  
162   21   CONTINUE            s00(jv) = s00(jv) + f0(i, 0, jv)
163  C            s0(i, 1, l, jv) = s0(i, 1, l, jv) - f0(i, 0, jv)
164        DO 22 JV=1,NTRA            sy(i, 1, l, jv) = alf1q(i, 0)*sy(i, 1, l, jv)
165        DO 220 I=1,LON            sx(i, 1, l, jv) = alf1(i, 0)*sx(i, 1, l, jv)
166  C            sz(i, 1, l, jv) = alf1(i, 0)*sz(i, 1, l, jv)
167           IF(VGRI(I,0,L).LE.0.) THEN  
168  C          END IF
169             F0(I,0,JV)=ALF(I,0)*  
170       +               ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )        END DO
171  C      END DO
172             S00(JV)=S00(JV)+F0(I,0,JV)  
173             S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)      DO i = 1, lon
174             sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)        IF (vgri(i,0,l)>0.) THEN
175             sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)          fm(i, 0) = vgri(i, 0, l)*dty
176             sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)          alf(i, 0) = fm(i, 0)/sm0
177  C        END IF
178           ENDIF      END DO
179  C  
180   220  CONTINUE      DO jv = 1, ntra
181   22   CONTINUE        DO i = 1, lon
182  C          IF (vgri(i,0,l)>0.) THEN
183        DO 23 I=1,LON            f0(i, 0, jv) = alf(i, 0)*s00(jv)
184           IF(VGRI(I,0,L).GT.0.) THEN          END IF
185             FM(I,0)=VGRI(I,0,L)*DTY        END DO
186             ALF(I,0)=FM(I,0)/SM0      END DO
187           ENDIF  
188   23   CONTINUE      ! puts the temporary moments Fi into appropriate neighboring boxes
189  C  
190        DO 24 JV=1,NTRA      DO i = 1, lon
191        DO 240 I=1,LON  
192           IF(VGRI(I,0,L).GT.0.) THEN        IF (vgri(i,0,l)>0.) THEN
193             F0(I,0,JV)=ALF(I,0)*S00(JV)          sm(i, 1, l) = sm(i, 1, l) + fm(i, 0)
194           ENDIF          alf(i, 0) = fm(i, 0)/sm(i, 1, l)
195   240  CONTINUE        END IF
196   24   CONTINUE  
197  C        alf1(i, 0) = 1. - alf(i, 0)
198  C  puts the temporary moments Fi into appropriate neighboring boxes  
199  C      END DO
200        DO 25 I=1,LON  
201  C      DO jv = 1, ntra
202           IF(VGRI(I,0,L).GT.0.) THEN        DO i = 1, lon
203             SM(I,1,L)=SM(I,1,L)+FM(I,0)  
204             ALF(I,0)=FM(I,0)/SM(I,1,L)          IF (vgri(i,0,l)>0.) THEN
205           ENDIF  
206  C            temptm = alf(i, 0)*s0(i, 1, l, jv) - alf1(i, 0)*f0(i, 0, jv)
207           ALF1(I,0)=1.-ALF(I,0)            s0(i, 1, l, jv) = s0(i, 1, l, jv) + f0(i, 0, jv)
208  C            sy(i, 1, l, jv) = alf1(i, 0)*sy(i, 1, l, jv) + 3.*temptm
209   25   CONTINUE  
210  C          END IF
211        DO 26 JV=1,NTRA  
212        DO 260 I=1,LON        END DO
213  C      END DO
214           IF(VGRI(I,0,L).GT.0.) THEN  
215  C      ! calculate flux and moments between adjacent boxes
216           TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)      ! 1- create temporary moments/masses for partial boxes in transit
217           S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)      ! 2- reajusts moments remaining in the box
218           sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM  
219  C      ! flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
220           ENDIF  
221  C      DO k = 1, lat - 1
222   260  CONTINUE        kp = k + 1
223   26   CONTINUE        DO i = 1, lon
224  C  
225  C  calculate flux and moments between adjacent boxes          IF (vgri(i,k,l)<0.) THEN
226  C  1- create temporary moments/masses for partial boxes in transit            fm(i, k) = -vgri(i, k, l)*dty
227  C  2- reajusts moments remaining in the box            alf(i, k) = fm(i, k)/sm(i, kp, l)
228  C            sm(i, kp, l) = sm(i, kp, l) - fm(i, k)
229  C  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0          ELSE
230  C            fm(i, k) = vgri(i, k, l)*dty
231        DO 30 K=1,LAT-1            alf(i, k) = fm(i, k)/sm(i, k, l)
232        KP=K+1            sm(i, k, l) = sm(i, k, l) - fm(i, k)
233        DO 300 I=1,LON          END IF
234  C  
235           IF(VGRI(I,K,L).LT.0.) THEN          alfq(i, k) = alf(i, k)*alf(i, k)
236             FM(I,K)=-VGRI(I,K,L)*DTY          alf1(i, k) = 1. - alf(i, k)
237             ALF(I,K)=FM(I,K)/SM(I,KP,L)          alf1q(i, k) = alf1(i, k)*alf1(i, k)
238             SM(I,KP,L)=SM(I,KP,L)-FM(I,K)  
239           ELSE        END DO
240             FM(I,K)=VGRI(I,K,L)*DTY      END DO
241             ALF(I,K)=FM(I,K)/SM(I,K,L)  
242             SM(I,K,L)=SM(I,K,L)-FM(I,K)      DO jv = 1, ntra
243           ENDIF        DO k = 1, lat - 1
244  C          kp = k + 1
245           ALFQ(I,K)=ALF(I,K)*ALF(I,K)          DO i = 1, lon
246           ALF1(I,K)=1.-ALF(I,K)  
247           ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)            IF (vgri(i,k,l)<0.) THEN
248  C  
249   300  CONTINUE              f0(i, k, jv) = alf(i, k)*(s0(i,kp,l,jv)-alf1(i,k)*sy(i,kp,l,jv))
250   30   CONTINUE              fy(i, k, jv) = alfq(i, k)*sy(i, kp, l, jv)
251  C              fx(i, k, jv) = alf(i, k)*sx(i, kp, l, jv)
252        DO 31 JV=1,NTRA              fz(i, k, jv) = alf(i, k)*sz(i, kp, l, jv)
253        DO 31 K=1,LAT-1  
254        KP=K+1              s0(i, kp, l, jv) = s0(i, kp, l, jv) - f0(i, k, jv)
255        DO 310 I=1,LON              sy(i, kp, l, jv) = alf1q(i, k)*sy(i, kp, l, jv)
256  C              sx(i, kp, l, jv) = sx(i, kp, l, jv) - fx(i, k, jv)
257           IF(VGRI(I,K,L).LT.0.) THEN              sz(i, kp, l, jv) = sz(i, kp, l, jv) - fz(i, k, jv)
258  C  
259             F0(I,K,JV)=ALF (I,K)*            ELSE
260       +                ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )  
261             FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)              f0(i, k, jv) = alf(i, k)*(s0(i,k,l,jv)+alf1(i,k)*sy(i,k,l,jv))
262             FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)              fy(i, k, jv) = alfq(i, k)*sy(i, k, l, jv)
263             FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)              fx(i, k, jv) = alf(i, k)*sx(i, k, l, jv)
264  C              fz(i, k, jv) = alf(i, k)*sz(i, k, l, jv)
265             S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)  
266             sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)              s0(i, k, l, jv) = s0(i, k, l, jv) - f0(i, k, jv)
267             sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)              sy(i, k, l, jv) = alf1q(i, k)*sy(i, k, l, jv)
268             sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)              sx(i, k, l, jv) = sx(i, k, l, jv) - fx(i, k, jv)
269  C              sz(i, k, l, jv) = sz(i, k, l, jv) - fz(i, k, jv)
270           ELSE  
271  C            END IF
272             F0(I,K,JV)=ALF (I,K)*  
273       +               ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )          END DO
274             FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)        END DO
275             FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)      END DO
276             FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)  
277  C      ! puts the temporary moments Fi into appropriate neighboring boxes
278             S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)  
279             sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)      DO k = 1, lat - 1
280             sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)        kp = k + 1
281             sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)        DO i = 1, lon
282  C  
283           ENDIF          IF (vgri(i,k,l)<0.) THEN
284  C            sm(i, k, l) = sm(i, k, l) + fm(i, k)
285   310  CONTINUE            alf(i, k) = fm(i, k)/sm(i, k, l)
286   31   CONTINUE          ELSE
287  C            sm(i, kp, l) = sm(i, kp, l) + fm(i, k)
288  C  puts the temporary moments Fi into appropriate neighboring boxes            alf(i, k) = fm(i, k)/sm(i, kp, l)
289  C          END IF
290        DO 32 K=1,LAT-1  
291        KP=K+1          alf1(i, k) = 1. - alf(i, k)
292        DO 320 I=1,LON  
293  C        END DO
294           IF(VGRI(I,K,L).LT.0.) THEN      END DO
295             SM(I,K,L)=SM(I,K,L)+FM(I,K)  
296             ALF(I,K)=FM(I,K)/SM(I,K,L)      DO jv = 1, ntra
297           ELSE        DO k = 1, lat - 1
298             SM(I,KP,L)=SM(I,KP,L)+FM(I,K)          kp = k + 1
299             ALF(I,K)=FM(I,K)/SM(I,KP,L)          DO i = 1, lon
300           ENDIF  
301  C            IF (vgri(i,k,l)<0.) THEN
302           ALF1(I,K)=1.-ALF(I,K)  
303  C              temptm = -alf(i, k)*s0(i, k, l, jv) + alf1(i, k)*f0(i, k, jv)
304   320  CONTINUE              s0(i, k, l, jv) = s0(i, k, l, jv) + f0(i, k, jv)
305   32   CONTINUE              sy(i, k, l, jv) = alf(i, k)*fy(i, k, jv) + &
306  C                alf1(i, k)*sy(i, k, l, jv) + 3.*temptm
307        DO 33 JV=1,NTRA              sx(i, k, l, jv) = sx(i, k, l, jv) + fx(i, k, jv)
308        DO 33 K=1,LAT-1              sz(i, k, l, jv) = sz(i, k, l, jv) + fz(i, k, jv)
309        KP=K+1  
310        DO 330 I=1,LON            ELSE
311  C  
312           IF(VGRI(I,K,L).LT.0.) THEN              temptm = alf(i, k)*s0(i, kp, l, jv) - alf1(i, k)*f0(i, k, jv)
313  C              s0(i, kp, l, jv) = s0(i, kp, l, jv) + f0(i, k, jv)
314           TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)              sy(i, kp, l, jv) = alf(i, k)*fy(i, k, jv) + &
315           S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)                alf1(i, k)*sy(i, kp, l, jv) + 3.*temptm
316           sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV)              sx(i, kp, l, jv) = sx(i, kp, l, jv) + fx(i, k, jv)
317       +               +3.*TEMPTM              sz(i, kp, l, jv) = sz(i, kp, l, jv) + fz(i, k, jv)
318           sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV)  
319           sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV)            END IF
320  C  
321           ELSE          END DO
322  C        END DO
323           TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)      END DO
324           S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)  
325           sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV)      ! traitement special pour le pole Sud (idem pole Nord)
326       +                +3.*TEMPTM  
327           sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV)      k = lat
328           sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV)  
329  C      sm0 = 0.
330           ENDIF      DO jv = 1, ntra
331  C        s00(jv) = 0.
332   330  CONTINUE      END DO
333   33   CONTINUE  
334  C      DO i = 1, lon
335  C  traitement special pour le pole Sud (idem pole Nord)  
336  C        IF (vgri(i,k,l)>=0.) THEN
337        K=LAT          fm(i, k) = vgri(i, k, l)*dty
338  C          alf(i, k) = fm(i, k)/sm(i, k, l)
339        SM0=0.          sm(i, k, l) = sm(i, k, l) - fm(i, k)
340        DO 40 JV=1,NTRA          sm0 = sm0 + fm(i, k)
341           S00(JV)=0.        END IF
342   40   CONTINUE  
343  C        alfq(i, k) = alf(i, k)*alf(i, k)
344        DO 41 I=1,LON        alf1(i, k) = 1. - alf(i, k)
345  C        alf1q(i, k) = alf1(i, k)*alf1(i, k)
346           IF(VGRI(I,K,L).GE.0.) THEN  
347             FM(I,K)=VGRI(I,K,L)*DTY      END DO
348             ALF(I,K)=FM(I,K)/SM(I,K,L)  
349             SM(I,K,L)=SM(I,K,L)-FM(I,K)      DO jv = 1, ntra
350             SM0=SM0+FM(I,K)        DO i = 1, lon
351           ENDIF  
352  C          IF (vgri(i,k,l)>=0.) THEN
353           ALFQ(I,K)=ALF(I,K)*ALF(I,K)            f0(i, k, jv) = alf(i, k)*(s0(i,k,l,jv)+alf1(i,k)*sy(i,k,l,jv))
354           ALF1(I,K)=1.-ALF(I,K)            s00(jv) = s00(jv) + f0(i, k, jv)
355           ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)  
356  C            s0(i, k, l, jv) = s0(i, k, l, jv) - f0(i, k, jv)
357   41   CONTINUE            sy(i, k, l, jv) = alf1q(i, k)*sy(i, k, l, jv)
358  C            sx(i, k, l, jv) = alf1(i, k)*sx(i, k, l, jv)
359        DO 42 JV=1,NTRA            sz(i, k, l, jv) = alf1(i, k)*sz(i, k, l, jv)
360        DO 420 I=1,LON          END IF
361  C  
362           IF(VGRI(I,K,L).GE.0.) THEN        END DO
363             F0 (I,K,JV)=ALF(I,K)*      END DO
364       +                ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )  
365             S00(JV)=S00(JV)+F0(I,K,JV)      DO i = 1, lon
366  C        IF (vgri(i,k,l)<0.) THEN
367             S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)          fm(i, k) = -vgri(i, k, l)*dty
368             sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)          alf(i, k) = fm(i, k)/sm0
369             sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)        END IF
370             sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)      END DO
371           ENDIF  
372  C      DO jv = 1, ntra
373   420  CONTINUE        DO i = 1, lon
374   42   CONTINUE          IF (vgri(i,k,l)<0.) THEN
375  C            f0(i, k, jv) = alf(i, k)*s00(jv)
376        DO 43 I=1,LON          END IF
377           IF(VGRI(I,K,L).LT.0.) THEN        END DO
378             FM(I,K)=-VGRI(I,K,L)*DTY      END DO
379             ALF(I,K)=FM(I,K)/SM0  
380           ENDIF      ! puts the temporary moments Fi into appropriate neighboring boxes
381   43   CONTINUE  
382  C      DO i = 1, lon
383        DO 44 JV=1,NTRA  
384        DO 440 I=1,LON        IF (vgri(i,k,l)<0.) THEN
385           IF(VGRI(I,K,L).LT.0.) THEN          sm(i, k, l) = sm(i, k, l) + fm(i, k)
386             F0(I,K,JV)=ALF(I,K)*S00(JV)          alf(i, k) = fm(i, k)/sm(i, k, l)
387           ENDIF        END IF
388   440  CONTINUE  
389   44   CONTINUE        alf1(i, k) = 1. - alf(i, k)
390  C  
391  C  puts the temporary moments Fi into appropriate neighboring boxes      END DO
392  C  
393        DO 45 I=1,LON      DO jv = 1, ntra
394  C        DO i = 1, lon
395           IF(VGRI(I,K,L).LT.0.) THEN  
396             SM(I,K,L)=SM(I,K,L)+FM(I,K)          IF (vgri(i,k,l)<0.) THEN
397             ALF(I,K)=FM(I,K)/SM(I,K,L)  
398           ENDIF            temptm = -alf(i, k)*s0(i, k, l, jv) + alf1(i, k)*f0(i, k, jv)
399  C            s0(i, k, l, jv) = s0(i, k, l, jv) + f0(i, k, jv)
400           ALF1(I,K)=1.-ALF(I,K)            sy(i, k, l, jv) = alf1(i, k)*sy(i, k, l, jv) + 3.*temptm
401  C  
402   45   CONTINUE          END IF
403  C  
404        DO 46 JV=1,NTRA        END DO
405        DO 460 I=1,LON      END DO
406  C  
407           IF(VGRI(I,K,L).LT.0.) THEN    END DO
408  C  
409           TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)    RETURN
410           S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)  END SUBROUTINE advy
          sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM  
 C  
          ENDIF  
 C  
  460  CONTINUE  
  46   CONTINUE  
 C  
  1    CONTINUE  
 C  
       RETURN  
       END  
411    
Legend:
Removed from v.66  
changed lines
  Added in v.112
  ViewVC Help
Powered by ViewVC 1.1.21