My Project
 All Classes Files Functions Variables Macros
advz.F
Go to the documentation of this file.
1 !
2 ! $Header$
3 !
4  SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz)
5  IMPLICIT NONE
6 
7 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8 C C
9 C first-order moments (FOM) advection of tracer in Z direction C
10 C C
11 C Source : Pascal Simon (Meteo,CNRM) C
12 C Adaptation : A.Armengaud (LGGE) juin 94 C
13 C C
14 C C
15 C sont des arguments d'entree pour le s-pg... C
16 C C
17 C dq est l'argument de sortie pour le s-pg C
18 C C
19 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
20 C
21 C parametres principaux du modele
22 C
23 #include "dimensions.h"
24 #include "paramet.h"
25 #include "comconst.h"
26 #include "comvert.h"
27 
28 C #include "traceur.h"
29 
30 C Arguments :
31 C -----------
32 C dtz : frequence fictive d'appel du transport
33 C w : flux de masse en z en Pa.m2.s-1
34 
35  INTEGER ntra
36  parameter(ntra = 1)
37 
38  REAL dtz
39  REAL w ( iip1,jjp1,llm )
40 
41 C moments: SM total mass in each grid box
42 C S0 mass of tracer in each grid box
43 C Si 1rst order moment in i direction
44 C
45  REAL sm(iip1,jjp1,llm)
46  + ,s0(iip1,jjp1,llm,ntra)
47  REAL sx(iip1,jjp1,llm,ntra)
48  + ,sy(iip1,jjp1,llm,ntra)
49  + ,sz(iip1,jjp1,llm,ntra)
50 
51 
52 C Local :
53 C -------
54 
55 C mass fluxes across the boundaries (UGRI,VGRI,WGRI)
56 C mass fluxes in kg
57 C declaration :
58 
59  REAL wgri(iip1,jjp1,0:llm)
60 
61 C
62 C the moments F are used as temporary storage for
63 C portions of grid boxes in transit at the current latitude
64 C
65  REAL fm(iim,llm)
66  REAL f0(iim,llm,ntra),fx(iim,llm,ntra)
67  REAL fy(iim,llm,ntra),fz(iim,llm,ntra)
68 C
69 C work arrays
70 C
71  REAL alf(iim),alf1(iim),alfq(iim),alf1q(iim)
72  REAL temptm ! Just temporal variable
73  REAL sqi,sqf
74 C
75  LOGICAL limit
76  INTEGER lon,lat,niv
77  INTEGER i,j,jv,k,l,lp
78 
79  lon = iim
80  lat = jjp1
81  niv = llm
82 
83 C *** Test de passage d'arguments ******
84 
85 c DO 399 l = 1, llm
86 c DO 399 j = 1, jjp1
87 c DO 399 i = 1, iip1
88 c IF (S0(i,j,l,ntra) .lt. 0. ) THEN
89 c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
90 c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
91 c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
92 c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
93 c PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ'
94 c STOP
95 c ENDIF
96  399 CONTINUE
97 
98 C-----------------------------------------------------------------
99 C *** Test : diag de la qqtite totale de traceur
100 C dans l'atmosphere avant l'advection en z
101  sqi = 0.
102  sqf = 0.
103 
104  DO l = 1,llm
105  DO j = 1,jjp1
106  DO i = 1,iim
107  sqi = sqi + s0(i,j,l,ntra)
108  ENDDO
109  ENDDO
110  ENDDO
111  print*,'-------- DIAG DANS ADVZ - ENTREE ---------'
112  print*,'sqi=',sqi
113 
114 C-----------------------------------------------------------------
115 C Interface : adaptation nouveau modele
116 C -------------------------------------
117 C
118 C Conversion du flux de masse en kg.s-1
119 
120  DO 500 l = 1,llm
121  DO 500 j = 1,jjp1
122  DO 500 i = 1,iip1
123 c wgri (i,j,llm+1-l) = w (i,j,l) / g
124  wgri(i,j,llm+1-l) = w(i,j,l)
125 c wgri (i,j,0) = 0. ! a detruire ult.
126 c wgri (i,j,l) = 0.1 ! w (i,j,l)
127 c wgri (i,j,llm) = 0. ! a detruire ult.
128  500 CONTINUE
129  DO j = 1,jjp1
130  DO i = 1,iip1
131  wgri(i,j,0)=0.
132  enddo
133  enddo
134 
135 C-----------------------------------------------------------------
136 
137 C start here
138 C boucle sur les latitudes
139 C
140  DO 1 k=1,lat
141 C
142 C place limits on appropriate moments before transport
143 C (if flux-limiting is to be applied)
144 C
145  IF(.NOT.limit) go to 101
146 C
147  DO 10 jv=1,ntra
148  DO 10 l=1,niv
149  DO 100 i=1,lon
150  sz(i,k,l,jv)=sign(amin1(amax1(s0(i,k,l,jv),0.),
151  + abs(sz(i,k,l,jv))),sz(i,k,l,jv))
152  100 CONTINUE
153  10 CONTINUE
154 C
155  101 CONTINUE
156 C
157 C boucle sur les niveaux intercouches de 1 a NIV-1
158 C (flux nul au sommet L=0 et a la base L=NIV)
159 C
160 C calculate flux and moments between adjacent boxes
161 C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
162 C 1- create temporary moments/masses for partial boxes in transit
163 C 2- reajusts moments remaining in the box
164 C
165  DO 11 l=1,niv-1
166  lp=l+1
167 C
168  DO 110 i=1,lon
169 C
170  IF(wgri(i,k,l).LT.0.) THEN
171  fm(i,l)=-wgri(i,k,l)*dtz
172  alf(i)=fm(i,l)/sm(i,k,lp)
173  sm(i,k,lp)=sm(i,k,lp)-fm(i,l)
174  ELSE
175  fm(i,l)=wgri(i,k,l)*dtz
176  alf(i)=fm(i,l)/sm(i,k,l)
177  sm(i,k,l)=sm(i,k,l)-fm(i,l)
178  ENDIF
179 C
180  alfq(i)=alf(i)*alf(i)
181  alf1(i)=1.-alf(i)
182  alf1q(i)=alf1(i)*alf1(i)
183 C
184  110 CONTINUE
185 C
186  DO 111 jv=1,ntra
187  DO 1110 i=1,lon
188 C
189  IF(wgri(i,k,l).LT.0.) THEN
190 C
191  f0(i,l,jv)=alf(i)*( s0(i,k,lp,jv)-alf1(i)*sz(i,k,lp,jv) )
192  fz(i,l,jv)=alfq(i)*sz(i,k,lp,jv)
193  fx(i,l,jv)=alf(i)*sx(i,k,lp,jv)
194  fy(i,l,jv)=alf(i)*sy(i,k,lp,jv)
195 C
196  s0(i,k,lp,jv)=s0(i,k,lp,jv)-f0(i,l,jv)
197  sz(i,k,lp,jv)=alf1q(i)*sz(i,k,lp,jv)
198  sx(i,k,lp,jv)=sx(i,k,lp,jv)-fx(i,l,jv)
199  sy(i,k,lp,jv)=sy(i,k,lp,jv)-fy(i,l,jv)
200 C
201  ELSE
202 C
203  f0(i,l,jv)=alf(i)*(s0(i,k,l,jv)+alf1(i)*sz(i,k,l,jv) )
204  fz(i,l,jv)=alfq(i)*sz(i,k,l,jv)
205  fx(i,l,jv)=alf(i)*sx(i,k,l,jv)
206  fy(i,l,jv)=alf(i)*sy(i,k,l,jv)
207 C
208  s0(i,k,l,jv)=s0(i,k,l,jv)-f0(i,l,jv)
209  sz(i,k,l,jv)=alf1q(i)*sz(i,k,l,jv)
210  sx(i,k,l,jv)=sx(i,k,l,jv)-fx(i,l,jv)
211  sy(i,k,l,jv)=sy(i,k,l,jv)-fy(i,l,jv)
212 C
213  ENDIF
214 C
215  1110 CONTINUE
216  111 CONTINUE
217 C
218  11 CONTINUE
219 C
220 C puts the temporary moments Fi into appropriate neighboring boxes
221 C
222  DO 12 l=1,niv-1
223  lp=l+1
224 C
225  DO 120 i=1,lon
226 C
227  IF(wgri(i,k,l).LT.0.) THEN
228  sm(i,k,l)=sm(i,k,l)+fm(i,l)
229  alf(i)=fm(i,l)/sm(i,k,l)
230  ELSE
231  sm(i,k,lp)=sm(i,k,lp)+fm(i,l)
232  alf(i)=fm(i,l)/sm(i,k,lp)
233  ENDIF
234 C
235  alf1(i)=1.-alf(i)
236  alfq(i)=alf(i)*alf(i)
237  alf1q(i)=alf1(i)*alf1(i)
238 C
239  120 CONTINUE
240 C
241  DO 121 jv=1,ntra
242  DO 1210 i=1,lon
243 C
244  IF(wgri(i,k,l).LT.0.) THEN
245 C
246  temptm=-alf(i)*s0(i,k,l,jv)+alf1(i)*f0(i,l,jv)
247  s0(i,k,l,jv)=s0(i,k,l,jv)+f0(i,l,jv)
248  sz(i,k,l,jv)=alf(i)*fz(i,l,jv)+alf1(i)*sz(i,k,l,jv)+3.*temptm
249  sx(i,k,l,jv)=sx(i,k,l,jv)+fx(i,l,jv)
250  sy(i,k,l,jv)=sy(i,k,l,jv)+fy(i,l,jv)
251 C
252  ELSE
253 C
254  temptm=alf(i)*s0(i,k,lp,jv)-alf1(i)*f0(i,l,jv)
255  s0(i,k,lp,jv)=s0(i,k,lp,jv)+f0(i,l,jv)
256  sz(i,k,lp,jv)=alf(i)*fz(i,l,jv)+alf1(i)*sz(i,k,lp,jv)
257  + +3.*temptm
258  sx(i,k,lp,jv)=sx(i,k,lp,jv)+fx(i,l,jv)
259  sy(i,k,lp,jv)=sy(i,k,lp,jv)+fy(i,l,jv)
260 C
261  ENDIF
262 C
263  1210 CONTINUE
264  121 CONTINUE
265 C
266  12 CONTINUE
267 C
268 C fin de la boucle principale sur les latitudes
269 C
270  1 CONTINUE
271 C
272 C-------------------------------------------------------------
273 C
274 C ----------- AA Test en fin de ADVX ------ Controle des S*
275 
276 c DO 9999 l = 1, llm
277 c DO 9999 j = 1, jjp1
278 c DO 9999 i = 1, iip1
279 c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
280 c PRINT*, '-------------------'
281 c PRINT*, 'En fin de ADVZ'
282 c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
283 c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
284 c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
285 c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
286 c WRITE (*,*) 'On arrete !! - pbl en fin de ADVZ1'
287 c STOP
288 c ENDIF
289  9999 CONTINUE
290 
291 C *** ------------------- bouclage cyclique en X ------------
292 
293 c DO l = 1,llm
294 c DO j = 1,jjp1
295 c SM(iip1,j,l) = SM(1,j,l)
296 c S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
297 C sx(iip1,j,l,ntra) = sx(1,j,l,ntra)
298 c sy(iip1,j,l,ntra) = sy(1,j,l,ntra)
299 c sz(iip1,j,l,ntra) = sz(1,j,l,ntra)
300 c ENDDO
301 c ENDDO
302 
303 C-------------------------------------------------------------
304 C *** Test : diag de la qqtite totale de traceur
305 C dans l'atmosphere avant l'advection en z
306  DO l = 1,llm
307  DO j = 1,jjp1
308  DO i = 1,iim
309  sqf = sqf + s0(i,j,l,ntra)
310  ENDDO
311  ENDDO
312  ENDDO
313  print*,'-------- DIAG DANS ADVZ - SORTIE ---------'
314  print*,'sqf=', sqf
315 
316 C-------------------------------------------------------------
317  RETURN
318  END
319 C_______________________________________________________________
320 C_______________________________________________________________