/[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 3 by guez, Wed Feb 27 13:16:39 2008 UTC trunk/Sources/dyn3d/advy.f revision 178 by guez, Fri Mar 11 18:47:26 2016 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 comvert    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 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    LOGICAL limit
88        REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn  
89        REAL sns0(ntra),snsz(ntra),snsm    lon = iim ! rem : Il est possible qu'un pbl. arrive ici
90        REAL s1v(llm),slatv(llm)    lat = jjp1 ! a cause des dim. differentes entre les
91        REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)    niv = llm
92        REAL cx1(llm,ntra), cxLAT(llm,ntra)  
93        REAL cy1(llm,ntra), cyLAT(llm,ntra)  
94        REAL z1(iim), zcos(iim), zsin(iim)    ! the moments Fi are used as temporary storage for
95        real smpn,smps,s0pn,s0ps    ! portions of the grid boxes in transit at the current level
96        REAL SSUM  
97        EXTERNAL SSUM    ! work arrays
98  C  
99        REAL sqi,sqf  
100        LOGICAL LIMIT    DO l = 1, llm
101        DO j = 1, jjm
102        lon = iim         ! rem : Il est possible qu'un pbl. arrive ici        DO i = 1, iip1
103        lat = jjp1        ! a cause des dim. differentes entre les          vgri(i, j, llm+1-l) = -1.*pbarv(i, j, l)
104        niv=llm        END DO
105        END DO
106  C      DO i = 1, iip1
107  C  the moments Fi are used as temporary storage for        vgri(i, 0, l) = 0.
108  C  portions of the grid boxes in transit at the current level        vgri(i, jjp1, l) = 0.
109  C      END DO
110  C  work arrays    END DO
111  C  
112      DO l = 1, niv
113        DO l = 1,llm  
114           DO j = 1,jjm      ! place limits on appropriate moments before transport
115              DO i = 1,iip1        ! (if flux-limiting is to be applied)
116              vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l)    
117              enddo      IF (.NOT. limit) GO TO 11
118           enddo  
119           do i=1,iip1      DO jv = 1, ntra
120               vgri(i,0,l) = 0.        DO k = 1, lat
121               vgri(i,jjp1,l) = 0.          DO i = 1, lon
122           enddo            sy(i, k, l, jv) = sign(amin1(amax1(s0(i,k,l,jv), &
123        enddo              0.),abs(sy(i,k,l,jv))), sy(i,k,l,jv))
124            END DO
125        DO 1 L=1,NIV        END DO
126  C      END DO
127  C  place limits on appropriate moments before transport  
128  C      (if flux-limiting is to be applied)  11  CONTINUE
129  C  
130        IF(.NOT.LIMIT) GO TO 11      ! le flux a travers le pole Nord est traite separement
131  C  
132        DO 10 JV=1,NTRA      sm0 = 0.
133        DO 10 K=1,LAT      DO jv = 1, ntra
134        DO 100 I=1,LON        s00(jv) = 0.
135           sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),      END DO
136       +                           ABS(sy(I,K,L,JV))),sy(I,K,L,JV))  
137   100  CONTINUE      DO i = 1, lon
138   10   CONTINUE  
139  C        IF (vgri(i,0,l)<=0.) THEN
140   11   CONTINUE          fm(i, 0) = -vgri(i, 0, l)*dty
141  C          alf(i, 0) = fm(i, 0)/sm(i, 1, l)
142  C  le flux a travers le pole Nord est traite separement          sm(i, 1, l) = sm(i, 1, l) - fm(i, 0)
143  C          sm0 = sm0 + fm(i, 0)
144        SM0=0.        END IF
145        DO 20 JV=1,NTRA  
146           S00(JV)=0.        alfq(i, 0) = alf(i, 0)*alf(i, 0)
147   20   CONTINUE        alf1(i, 0) = 1. - alf(i, 0)
148  C        alf1q(i, 0) = alf1(i, 0)*alf1(i, 0)
149        DO 21 I=1,LON  
150  C      END DO
151           IF(VGRI(I,0,L).LE.0.) THEN  
152             FM(I,0)=-VGRI(I,0,L)*DTY      DO jv = 1, ntra
153             ALF(I,0)=FM(I,0)/SM(I,1,L)        DO i = 1, lon
154             SM(I,1,L)=SM(I,1,L)-FM(I,0)  
155             SM0=SM0+FM(I,0)          IF (vgri(i,0,l)<=0.) THEN
156           ENDIF  
157  C            f0(i, 0, jv) = alf(i, 0)*(s0(i,1,l,jv)-alf1(i,0)*sy(i,1,l,jv))
158           ALFQ(I,0)=ALF(I,0)*ALF(I,0)  
159           ALF1(I,0)=1.-ALF(I,0)            s00(jv) = s00(jv) + f0(i, 0, jv)
160           ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)            s0(i, 1, l, jv) = s0(i, 1, l, jv) - f0(i, 0, jv)
161  C            sy(i, 1, l, jv) = alf1q(i, 0)*sy(i, 1, l, jv)
162   21   CONTINUE            sx(i, 1, l, jv) = alf1(i, 0)*sx(i, 1, l, jv)
163  C            sz(i, 1, l, jv) = alf1(i, 0)*sz(i, 1, l, jv)
164        DO 22 JV=1,NTRA  
165        DO 220 I=1,LON          END IF
166  C  
167           IF(VGRI(I,0,L).LE.0.) THEN        END DO
168  C      END DO
169             F0(I,0,JV)=ALF(I,0)*  
170       +               ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )      DO i = 1, lon
171  C        IF (vgri(i,0,l)>0.) THEN
172             S00(JV)=S00(JV)+F0(I,0,JV)          fm(i, 0) = vgri(i, 0, l)*dty
173             S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)          alf(i, 0) = fm(i, 0)/sm0
174             sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)        END IF
175             sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)      END DO
176             sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)  
177  C      DO jv = 1, ntra
178           ENDIF        DO i = 1, lon
179  C          IF (vgri(i,0,l)>0.) THEN
180   220  CONTINUE            f0(i, 0, jv) = alf(i, 0)*s00(jv)
181   22   CONTINUE          END IF
182  C        END DO
183        DO 23 I=1,LON      END DO
184           IF(VGRI(I,0,L).GT.0.) THEN  
185             FM(I,0)=VGRI(I,0,L)*DTY      ! puts the temporary moments Fi into appropriate neighboring boxes
186             ALF(I,0)=FM(I,0)/SM0  
187           ENDIF      DO i = 1, lon
188   23   CONTINUE  
189  C        IF (vgri(i,0,l)>0.) THEN
190        DO 24 JV=1,NTRA          sm(i, 1, l) = sm(i, 1, l) + fm(i, 0)
191        DO 240 I=1,LON          alf(i, 0) = fm(i, 0)/sm(i, 1, l)
192           IF(VGRI(I,0,L).GT.0.) THEN        END IF
193             F0(I,0,JV)=ALF(I,0)*S00(JV)  
194           ENDIF        alf1(i, 0) = 1. - alf(i, 0)
195   240  CONTINUE  
196   24   CONTINUE      END DO
197  C  
198  C  puts the temporary moments Fi into appropriate neighboring boxes      DO jv = 1, ntra
199  C        DO i = 1, lon
200        DO 25 I=1,LON  
201  C          IF (vgri(i,0,l)>0.) THEN
202           IF(VGRI(I,0,L).GT.0.) THEN  
203             SM(I,1,L)=SM(I,1,L)+FM(I,0)            temptm = alf(i, 0)*s0(i, 1, l, jv) - alf1(i, 0)*f0(i, 0, jv)
204             ALF(I,0)=FM(I,0)/SM(I,1,L)            s0(i, 1, l, jv) = s0(i, 1, l, jv) + f0(i, 0, jv)
205           ENDIF            sy(i, 1, l, jv) = alf1(i, 0)*sy(i, 1, l, jv) + 3.*temptm
206  C  
207           ALF1(I,0)=1.-ALF(I,0)          END IF
208  C  
209   25   CONTINUE        END DO
210  C      END DO
211        DO 26 JV=1,NTRA  
212        DO 260 I=1,LON      ! calculate flux and moments between adjacent boxes
213  C      ! 1- create temporary moments/masses for partial boxes in transit
214           IF(VGRI(I,0,L).GT.0.) THEN      ! 2- reajusts moments remaining in the box
215  C  
216           TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)      ! flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
217           S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)  
218           sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM      DO k = 1, lat - 1
219  C        kp = k + 1
220           ENDIF        DO i = 1, lon
221  C  
222   260  CONTINUE          IF (vgri(i,k,l)<0.) THEN
223   26   CONTINUE            fm(i, k) = -vgri(i, k, l)*dty
224  C            alf(i, k) = fm(i, k)/sm(i, kp, l)
225  C  calculate flux and moments between adjacent boxes            sm(i, kp, l) = sm(i, kp, l) - fm(i, k)
226  C  1- create temporary moments/masses for partial boxes in transit          ELSE
227  C  2- reajusts moments remaining in the box            fm(i, k) = vgri(i, k, l)*dty
228  C            alf(i, k) = fm(i, k)/sm(i, k, l)
229  C  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0            sm(i, k, l) = sm(i, k, l) - fm(i, k)
230  C          END IF
231        DO 30 K=1,LAT-1  
232        KP=K+1          alfq(i, k) = alf(i, k)*alf(i, k)
233        DO 300 I=1,LON          alf1(i, k) = 1. - alf(i, k)
234  C          alf1q(i, k) = alf1(i, k)*alf1(i, k)
235           IF(VGRI(I,K,L).LT.0.) THEN  
236             FM(I,K)=-VGRI(I,K,L)*DTY        END DO
237             ALF(I,K)=FM(I,K)/SM(I,KP,L)      END DO
238             SM(I,KP,L)=SM(I,KP,L)-FM(I,K)  
239           ELSE      DO jv = 1, ntra
240             FM(I,K)=VGRI(I,K,L)*DTY        DO k = 1, lat - 1
241             ALF(I,K)=FM(I,K)/SM(I,K,L)          kp = k + 1
242             SM(I,K,L)=SM(I,K,L)-FM(I,K)          DO i = 1, lon
243           ENDIF  
244  C            IF (vgri(i,k,l)<0.) THEN
245           ALFQ(I,K)=ALF(I,K)*ALF(I,K)  
246           ALF1(I,K)=1.-ALF(I,K)              f0(i, k, jv) = alf(i, k)*(s0(i,kp,l,jv)-alf1(i,k)*sy(i,kp,l,jv))
247           ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)              fy(i, k, jv) = alfq(i, k)*sy(i, kp, l, jv)
248  C              fx(i, k, jv) = alf(i, k)*sx(i, kp, l, jv)
249   300  CONTINUE              fz(i, k, jv) = alf(i, k)*sz(i, kp, l, jv)
250   30   CONTINUE  
251  C              s0(i, kp, l, jv) = s0(i, kp, l, jv) - f0(i, k, jv)
252        DO 31 JV=1,NTRA              sy(i, kp, l, jv) = alf1q(i, k)*sy(i, kp, l, jv)
253        DO 31 K=1,LAT-1              sx(i, kp, l, jv) = sx(i, kp, l, jv) - fx(i, k, jv)
254        KP=K+1              sz(i, kp, l, jv) = sz(i, kp, l, jv) - fz(i, k, jv)
255        DO 310 I=1,LON  
256  C            ELSE
257           IF(VGRI(I,K,L).LT.0.) THEN  
258  C              f0(i, k, jv) = alf(i, k)*(s0(i,k,l,jv)+alf1(i,k)*sy(i,k,l,jv))
259             F0(I,K,JV)=ALF (I,K)*              fy(i, k, jv) = alfq(i, k)*sy(i, k, l, jv)
260       +                ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )              fx(i, k, jv) = alf(i, k)*sx(i, k, l, jv)
261             FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)              fz(i, k, jv) = alf(i, k)*sz(i, k, l, jv)
262             FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)  
263             FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)              s0(i, k, l, jv) = s0(i, k, l, jv) - f0(i, k, jv)
264  C              sy(i, k, l, jv) = alf1q(i, k)*sy(i, k, l, jv)
265             S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)              sx(i, k, l, jv) = sx(i, k, l, jv) - fx(i, k, jv)
266             sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)              sz(i, k, l, jv) = sz(i, k, l, jv) - fz(i, k, jv)
267             sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)  
268             sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)            END IF
269  C  
270           ELSE          END DO
271  C        END DO
272             F0(I,K,JV)=ALF (I,K)*      END DO
273       +               ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )  
274             FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)      ! puts the temporary moments Fi into appropriate neighboring boxes
275             FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)  
276             FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)      DO k = 1, lat - 1
277  C        kp = k + 1
278             S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)        DO i = 1, lon
279             sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)  
280             sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)          IF (vgri(i,k,l)<0.) THEN
281             sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)            sm(i, k, l) = sm(i, k, l) + fm(i, k)
282  C            alf(i, k) = fm(i, k)/sm(i, k, l)
283           ENDIF          ELSE
284  C            sm(i, kp, l) = sm(i, kp, l) + fm(i, k)
285   310  CONTINUE            alf(i, k) = fm(i, k)/sm(i, kp, l)
286   31   CONTINUE          END IF
287  C  
288  C  puts the temporary moments Fi into appropriate neighboring boxes          alf1(i, k) = 1. - alf(i, k)
289  C  
290        DO 32 K=1,LAT-1        END DO
291        KP=K+1      END DO
292        DO 320 I=1,LON  
293  C      DO jv = 1, ntra
294           IF(VGRI(I,K,L).LT.0.) THEN        DO k = 1, lat - 1
295             SM(I,K,L)=SM(I,K,L)+FM(I,K)          kp = k + 1
296             ALF(I,K)=FM(I,K)/SM(I,K,L)          DO i = 1, lon
297           ELSE  
298             SM(I,KP,L)=SM(I,KP,L)+FM(I,K)            IF (vgri(i,k,l)<0.) THEN
299             ALF(I,K)=FM(I,K)/SM(I,KP,L)  
300           ENDIF              temptm = -alf(i, k)*s0(i, k, l, jv) + alf1(i, k)*f0(i, k, jv)
301  C              s0(i, k, l, jv) = s0(i, k, l, jv) + f0(i, k, jv)
302           ALF1(I,K)=1.-ALF(I,K)              sy(i, k, l, jv) = alf(i, k)*fy(i, k, jv) + &
303  C                alf1(i, k)*sy(i, k, l, jv) + 3.*temptm
304   320  CONTINUE              sx(i, k, l, jv) = sx(i, k, l, jv) + fx(i, k, jv)
305   32   CONTINUE              sz(i, k, l, jv) = sz(i, k, l, jv) + fz(i, k, jv)
306  C  
307        DO 33 JV=1,NTRA            ELSE
308        DO 33 K=1,LAT-1  
309        KP=K+1              temptm = alf(i, k)*s0(i, kp, l, jv) - alf1(i, k)*f0(i, k, jv)
310        DO 330 I=1,LON              s0(i, kp, l, jv) = s0(i, kp, l, jv) + f0(i, k, jv)
311  C              sy(i, kp, l, jv) = alf(i, k)*fy(i, k, jv) + &
312           IF(VGRI(I,K,L).LT.0.) THEN                alf1(i, k)*sy(i, kp, l, jv) + 3.*temptm
313  C              sx(i, kp, l, jv) = sx(i, kp, l, jv) + fx(i, k, jv)
314           TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)              sz(i, kp, l, jv) = sz(i, kp, l, jv) + fz(i, k, jv)
315           S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)  
316           sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV)            END IF
317       +               +3.*TEMPTM  
318           sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV)          END DO
319           sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV)        END DO
320  C      END DO
321           ELSE  
322  C      ! traitement special pour le pole Sud (idem pole Nord)
323           TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)  
324           S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)      k = lat
325           sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV)  
326       +                +3.*TEMPTM      sm0 = 0.
327           sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV)      DO jv = 1, ntra
328           sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV)        s00(jv) = 0.
329  C      END DO
330           ENDIF  
331  C      DO i = 1, lon
332   330  CONTINUE  
333   33   CONTINUE        IF (vgri(i,k,l)>=0.) THEN
334  C          fm(i, k) = vgri(i, k, l)*dty
335  C  traitement special pour le pole Sud (idem pole Nord)          alf(i, k) = fm(i, k)/sm(i, k, l)
336  C          sm(i, k, l) = sm(i, k, l) - fm(i, k)
337        K=LAT          sm0 = sm0 + fm(i, k)
338  C        END IF
339        SM0=0.  
340        DO 40 JV=1,NTRA        alfq(i, k) = alf(i, k)*alf(i, k)
341           S00(JV)=0.        alf1(i, k) = 1. - alf(i, k)
342   40   CONTINUE        alf1q(i, k) = alf1(i, k)*alf1(i, k)
343  C  
344        DO 41 I=1,LON      END DO
345  C  
346           IF(VGRI(I,K,L).GE.0.) THEN      DO jv = 1, ntra
347             FM(I,K)=VGRI(I,K,L)*DTY        DO i = 1, lon
348             ALF(I,K)=FM(I,K)/SM(I,K,L)  
349             SM(I,K,L)=SM(I,K,L)-FM(I,K)          IF (vgri(i,k,l)>=0.) THEN
350             SM0=SM0+FM(I,K)            f0(i, k, jv) = alf(i, k)*(s0(i,k,l,jv)+alf1(i,k)*sy(i,k,l,jv))
351           ENDIF            s00(jv) = s00(jv) + f0(i, k, jv)
352  C  
353           ALFQ(I,K)=ALF(I,K)*ALF(I,K)            s0(i, k, l, jv) = s0(i, k, l, jv) - f0(i, k, jv)
354           ALF1(I,K)=1.-ALF(I,K)            sy(i, k, l, jv) = alf1q(i, k)*sy(i, k, l, jv)
355           ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)            sx(i, k, l, jv) = alf1(i, k)*sx(i, k, l, jv)
356  C            sz(i, k, l, jv) = alf1(i, k)*sz(i, k, l, jv)
357   41   CONTINUE          END IF
358  C  
359        DO 42 JV=1,NTRA        END DO
360        DO 420 I=1,LON      END DO
361  C  
362           IF(VGRI(I,K,L).GE.0.) THEN      DO i = 1, lon
363             F0 (I,K,JV)=ALF(I,K)*        IF (vgri(i,k,l)<0.) THEN
364       +                ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )          fm(i, k) = -vgri(i, k, l)*dty
365             S00(JV)=S00(JV)+F0(I,K,JV)          alf(i, k) = fm(i, k)/sm0
366  C        END IF
367             S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)      END DO
368             sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)  
369             sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)      DO jv = 1, ntra
370             sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)        DO i = 1, lon
371           ENDIF          IF (vgri(i,k,l)<0.) THEN
372  C            f0(i, k, jv) = alf(i, k)*s00(jv)
373   420  CONTINUE          END IF
374   42   CONTINUE        END DO
375  C      END DO
376        DO 43 I=1,LON  
377           IF(VGRI(I,K,L).LT.0.) THEN      ! puts the temporary moments Fi into appropriate neighboring boxes
378             FM(I,K)=-VGRI(I,K,L)*DTY  
379             ALF(I,K)=FM(I,K)/SM0      DO i = 1, lon
380           ENDIF  
381   43   CONTINUE        IF (vgri(i,k,l)<0.) THEN
382  C          sm(i, k, l) = sm(i, k, l) + fm(i, k)
383        DO 44 JV=1,NTRA          alf(i, k) = fm(i, k)/sm(i, k, l)
384        DO 440 I=1,LON        END IF
385           IF(VGRI(I,K,L).LT.0.) THEN  
386             F0(I,K,JV)=ALF(I,K)*S00(JV)        alf1(i, k) = 1. - alf(i, k)
387           ENDIF  
388   440  CONTINUE      END DO
389   44   CONTINUE  
390  C      DO jv = 1, ntra
391  C  puts the temporary moments Fi into appropriate neighboring boxes        DO i = 1, lon
392  C  
393        DO 45 I=1,LON          IF (vgri(i,k,l)<0.) THEN
394  C  
395           IF(VGRI(I,K,L).LT.0.) THEN            temptm = -alf(i, k)*s0(i, k, l, jv) + alf1(i, k)*f0(i, k, jv)
396             SM(I,K,L)=SM(I,K,L)+FM(I,K)            s0(i, k, l, jv) = s0(i, k, l, jv) + f0(i, k, jv)
397             ALF(I,K)=FM(I,K)/SM(I,K,L)            sy(i, k, l, jv) = alf1(i, k)*sy(i, k, l, jv) + 3.*temptm
398           ENDIF  
399  C          END IF
400           ALF1(I,K)=1.-ALF(I,K)  
401  C        END DO
402   45   CONTINUE      END DO
403  C  
404        DO 46 JV=1,NTRA    END DO
405        DO 460 I=1,LON  
406  C    RETURN
407           IF(VGRI(I,K,L).LT.0.) THEN  END SUBROUTINE advy
 C  
          TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)  
          S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)  
          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  
408    
Legend:
Removed from v.3  
changed lines
  Added in v.178
  ViewVC Help
Powered by ViewVC 1.1.21