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

Diff of /trunk/dyn3d/advy.f

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

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