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