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