Context Navigation

advy.F @ 5160

Last change on this file since 5160 was 5084, checked in by Laurent Fairhead, 4 months ago
Reverting to r4065. Updating fortran standard broke too much stuff. Will do it by smaller chunks AB, LF
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 10.4 KB

Line
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 "comgeom2.h"
31
32	C Arguments :
33	C ----------
34	C dty : frequence fictive d'appel du transport
35	C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
36
37	INTEGER lon,lat,niv
38	INTEGER i,j,jv,k,kp,l
39	INTEGER ntra
40	PARAMETER (ntra = 1)
41
42	REAL dty
43	REAL pbarv ( iip1,jjm, llm )
44
45	C moments: SM total mass in each grid box
46	C S0 mass of tracer in each grid box
47	C Si 1rst order moment in i direction
48	C
49	REAL SM(iip1,jjp1,llm)
50	+ ,S0(iip1,jjp1,llm,ntra)
51	REAL sx(iip1,jjp1,llm,ntra)
52	+ ,sy(iip1,jjp1,llm,ntra)
53	+ ,sz(iip1,jjp1,llm,ntra)
54
55
56	C Local :
57	C -------
58
59	C mass fluxes across the boundaries (UGRI,VGRI,WGRI)
60	C mass fluxes in kg
61	C declaration :
62
63	REAL VGRI(iip1,0:jjp1,llm)
64
65	C Rem : UGRI et WGRI ne sont pas utilises dans
66	C cette subroutine ( advection en y uniquement )
67	C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
68	C
69	C the moments F are similarly defined and used as temporary
70	C storage for portions of the grid boxes in transit
71	C
72	REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
73	REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
74	REAL FZ(iim,jjm,ntra)
75	REAL S00(ntra)
76	REAL SM0 ! Just temporal variable
77	C
78	C work arrays
79	C
80	REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
81	REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
82	REAL TEMPTM ! Just temporal variable
83	c
84	C Special pour poles
85	c
86	REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
87	REAL sns0(ntra),snsz(ntra),snsm
88	REAL s1v(llm),slatv(llm)
89	REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
90	REAL cx1(llm,ntra), cxLAT(llm,ntra)
91	REAL cy1(llm,ntra), cyLAT(llm,ntra)
92	REAL z1(iim), zcos(iim), zsin(iim)
93	real smpn,smps,s0pn,s0ps
94	REAL SSUM
95	EXTERNAL SSUM
96	C
97	REAL sqi,sqf
98	LOGICAL LIMIT
99
100	lon = iim ! rem : Il est possible qu'un pbl. arrive ici
101	lat = jjp1 ! a cause des dim. differentes entre les
102	niv=llm
103
104	C
105	C the moments Fi are used as temporary storage for
106	C portions of the grid boxes in transit at the current level
107	C
108	C work arrays
109	C
110
111	DO l = 1,llm
112	DO j = 1,jjm
113	DO i = 1,iip1
114	vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l)
115	enddo
116	enddo
117	do i=1,iip1
118	vgri(i,0,l) = 0.
119	vgri(i,jjp1,l) = 0.
120	enddo
121	enddo
122
123	DO 1 L=1,NIV
124	C
125	C place limits on appropriate moments before transport
126	C (if flux-limiting is to be applied)
127	C
128	IF(.NOT.LIMIT) GO TO 11
129	C
130	DO 10 JV=1,NTRA
131	DO 10 K=1,LAT
132	DO 100 I=1,LON
133	sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),
134	+ ABS(sy(I,K,L,JV))),sy(I,K,L,JV))
135	100 CONTINUE
136	10 CONTINUE
137	C
138	11 CONTINUE
139	C
140	C le flux a travers le pole Nord est traite separement
141	C
142	SM0=0.
143	DO 20 JV=1,NTRA
144	S00(JV)=0.
145	20 CONTINUE
146	C
147	DO 21 I=1,LON
148	C
149	IF(VGRI(I,0,L).LE.0.) THEN
150	FM(I,0)=-VGRI(I,0,L)*DTY
151	ALF(I,0)=FM(I,0)/SM(I,1,L)
152	SM(I,1,L)=SM(I,1,L)-FM(I,0)
153	SM0=SM0+FM(I,0)
154	ENDIF
155	C
156	ALFQ(I,0)=ALF(I,0)*ALF(I,0)
157	ALF1(I,0)=1.-ALF(I,0)
158	ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
159	C
160	21 CONTINUE
161	C
162	DO 22 JV=1,NTRA
163	DO 220 I=1,LON
164	C
165	IF(VGRI(I,0,L).LE.0.) THEN
166	C
167	F0(I,0,JV)=ALF(I,0)*
168	+ ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )
169	C
170	S00(JV)=S00(JV)+F0(I,0,JV)
171	S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
172	sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)
173	sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)
174	sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)
175	C
176	ENDIF
177	C
178	220 CONTINUE
179	22 CONTINUE
180	C
181	DO 23 I=1,LON
182	IF(VGRI(I,0,L).GT.0.) THEN
183	FM(I,0)=VGRI(I,0,L)*DTY
184	ALF(I,0)=FM(I,0)/SM0
185	ENDIF
186	23 CONTINUE
187	C
188	DO 24 JV=1,NTRA
189	DO 240 I=1,LON
190	IF(VGRI(I,0,L).GT.0.) THEN
191	F0(I,0,JV)=ALF(I,0)*S00(JV)
192	ENDIF
193	240 CONTINUE
194	24 CONTINUE
195	C
196	C puts the temporary moments Fi into appropriate neighboring boxes
197	C
198	DO 25 I=1,LON
199	C
200	IF(VGRI(I,0,L).GT.0.) THEN
201	SM(I,1,L)=SM(I,1,L)+FM(I,0)
202	ALF(I,0)=FM(I,0)/SM(I,1,L)
203	ENDIF
204	C
205	ALF1(I,0)=1.-ALF(I,0)
206	C
207	25 CONTINUE
208	C
209	DO 26 JV=1,NTRA
210	DO 260 I=1,LON
211	C
212	IF(VGRI(I,0,L).GT.0.) THEN
213	C
214	TEMPTM=ALF(I,0)S0(I,1,L,JV)-ALF1(I,0)F0(I,0,JV)
215	S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
216	sy(I,1,L,JV)=ALF1(I,0)sy(I,1,L,JV)+3.TEMPTM
217	C
218	ENDIF
219	C
220	260 CONTINUE
221	26 CONTINUE
222	C
223	C calculate flux and moments between adjacent boxes
224	C 1- create temporary moments/masses for partial boxes in transit
225	C 2- reajusts moments remaining in the box
226	C
227	C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
228	C
229	DO 30 K=1,LAT-1
230	KP=K+1
231	DO 300 I=1,LON
232	C
233	IF(VGRI(I,K,L).LT.0.) THEN
234	FM(I,K)=-VGRI(I,K,L)*DTY
235	ALF(I,K)=FM(I,K)/SM(I,KP,L)
236	SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
237	ELSE
238	FM(I,K)=VGRI(I,K,L)*DTY
239	ALF(I,K)=FM(I,K)/SM(I,K,L)
240	SM(I,K,L)=SM(I,K,L)-FM(I,K)
241	ENDIF
242	C
243	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
244	ALF1(I,K)=1.-ALF(I,K)
245	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
246	C
247	300 CONTINUE
248	30 CONTINUE
249	C
250	DO 31 JV=1,NTRA
251	DO 31 K=1,LAT-1
252	KP=K+1
253	DO 310 I=1,LON
254	C
255	IF(VGRI(I,K,L).LT.0.) THEN
256	C
257	F0(I,K,JV)=ALF (I,K)*
258	+ ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )
259	FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)
260	FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)
261	FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)
262	C
263	S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
264	sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)
265	sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)
266	sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)
267	C
268	ELSE
269	C
270	F0(I,K,JV)=ALF (I,K)*
271	+ ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
272	FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)
273	FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)
274	FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)
275	C
276	S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)
277	sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
278	sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)
279	sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)
280	C
281	ENDIF
282	C
283	310 CONTINUE
284	31 CONTINUE
285	C
286	C puts the temporary moments Fi into appropriate neighboring boxes
287	C
288	DO 32 K=1,LAT-1
289	KP=K+1
290	DO 320 I=1,LON
291	C
292	IF(VGRI(I,K,L).LT.0.) THEN
293	SM(I,K,L)=SM(I,K,L)+FM(I,K)
294	ALF(I,K)=FM(I,K)/SM(I,K,L)
295	ELSE
296	SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
297	ALF(I,K)=FM(I,K)/SM(I,KP,L)
298	ENDIF
299	C
300	ALF1(I,K)=1.-ALF(I,K)
301	C
302	320 CONTINUE
303	32 CONTINUE
304	C
305	DO 33 JV=1,NTRA
306	DO 33 K=1,LAT-1
307	KP=K+1
308	DO 330 I=1,LON
309	C
310	IF(VGRI(I,K,L).LT.0.) THEN
311	C
312	TEMPTM=-ALF(I,K)S0(I,K,L,JV)+ALF1(I,K)F0(I,K,JV)
313	S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
314	sy(I,K,L,JV)=ALF(I,K)FY(I,K,JV)+ALF1(I,K)sy(I,K,L,JV)
315	+ +3.*TEMPTM
316	sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV)
317	sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV)
318	C
319	ELSE
320	C
321	TEMPTM=ALF(I,K)S0(I,KP,L,JV)-ALF1(I,K)F0(I,K,JV)
322	S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
323	sy(I,KP,L,JV)=ALF(I,K)FY(I,K,JV)+ALF1(I,K)sy(I,KP,L,JV)
324	+ +3.*TEMPTM
325	sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV)
326	sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV)
327	C
328	ENDIF
329	C
330	330 CONTINUE
331	33 CONTINUE
332	C
333	C traitement special pour le pole Sud (idem pole Nord)
334	C
335	K=LAT
336	C
337	SM0=0.
338	DO 40 JV=1,NTRA
339	S00(JV)=0.
340	40 CONTINUE
341	C
342	DO 41 I=1,LON
343	C
344	IF(VGRI(I,K,L).GE.0.) THEN
345	FM(I,K)=VGRI(I,K,L)*DTY
346	ALF(I,K)=FM(I,K)/SM(I,K,L)
347	SM(I,K,L)=SM(I,K,L)-FM(I,K)
348	SM0=SM0+FM(I,K)
349	ENDIF
350	C
351	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
352	ALF1(I,K)=1.-ALF(I,K)
353	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
354	C
355	41 CONTINUE
356	C
357	DO 42 JV=1,NTRA
358	DO 420 I=1,LON
359	C
360	IF(VGRI(I,K,L).GE.0.) THEN
361	F0 (I,K,JV)=ALF(I,K)*
362	+ ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
363	S00(JV)=S00(JV)+F0(I,K,JV)
364	C
365	S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
366	sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
367	sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)
368	sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)
369	ENDIF
370	C
371	420 CONTINUE
372	42 CONTINUE
373	C
374	DO 43 I=1,LON
375	IF(VGRI(I,K,L).LT.0.) THEN
376	FM(I,K)=-VGRI(I,K,L)*DTY
377	ALF(I,K)=FM(I,K)/SM0
378	ENDIF
379	43 CONTINUE
380	C
381	DO 44 JV=1,NTRA
382	DO 440 I=1,LON
383	IF(VGRI(I,K,L).LT.0.) THEN
384	F0(I,K,JV)=ALF(I,K)*S00(JV)
385	ENDIF
386	440 CONTINUE
387	44 CONTINUE
388	C
389	C puts the temporary moments Fi into appropriate neighboring boxes
390	C
391	DO 45 I=1,LON
392	C
393	IF(VGRI(I,K,L).LT.0.) THEN
394	SM(I,K,L)=SM(I,K,L)+FM(I,K)
395	ALF(I,K)=FM(I,K)/SM(I,K,L)
396	ENDIF
397	C
398	ALF1(I,K)=1.-ALF(I,K)
399	C
400	45 CONTINUE
401	C
402	DO 46 JV=1,NTRA
403	DO 460 I=1,LON
404	C
405	IF(VGRI(I,K,L).LT.0.) THEN
406	C
407	TEMPTM=-ALF(I,K)S0(I,K,L,JV)+ALF1(I,K)F0(I,K,JV)
408	S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
409	sy(I,K,L,JV)=ALF1(I,K)sy(I,K,L,JV)+3.TEMPTM
410	C
411	ENDIF
412	C
413	460 CONTINUE
414	46 CONTINUE
415	C
416	1 CONTINUE
417	C
418	RETURN
419	END
420

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format