Context Navigation

advy.F @ 5098

Last change on this file since 5098 was 5079, checked in by abarral, 4 months ago
[coherence with Fortran standards] Replace obsolete DO with shared termination (minor) replace obsolete bool operators
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.2 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 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 JV=1,NTRA
131	DO K=1,LAT
132	DO 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	END DO
136	END DO
137	END DO
138	C
139	11 CONTINUE
140	C
141	C le flux a travers le pole Nord est traite separement
142	C
143	SM0=0.
144	DO JV=1,NTRA
145	S00(JV)=0.
146	END DO
147	C
148	DO I=1,LON
149	C
150	IF(VGRI(I,0,L)<=0.) THEN
151	FM(I,0)=-VGRI(I,0,L)*DTY
152	ALF(I,0)=FM(I,0)/SM(I,1,L)
153	SM(I,1,L)=SM(I,1,L)-FM(I,0)
154	SM0=SM0+FM(I,0)
155	ENDIF
156	C
157	ALFQ(I,0)=ALF(I,0)*ALF(I,0)
158	ALF1(I,0)=1.-ALF(I,0)
159	ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
160	C
161	END DO
162	C
163	DO JV=1,NTRA
164	DO I=1,LON
165	C
166	IF(VGRI(I,0,L)<=0.) THEN
167	C
168	F0(I,0,JV)=ALF(I,0)*
169	+ ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )
170	C
171	S00(JV)=S00(JV)+F0(I,0,JV)
172	S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
173	sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)
174	sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)
175	sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)
176	C
177	ENDIF
178	C
179	END DO
180	END DO
181	C
182	DO I=1,LON
183	IF(VGRI(I,0,L)>0.) THEN
184	FM(I,0)=VGRI(I,0,L)*DTY
185	ALF(I,0)=FM(I,0)/SM0
186	ENDIF
187	END DO
188	C
189	DO JV=1,NTRA
190	DO I=1,LON
191	IF(VGRI(I,0,L)>0.) THEN
192	F0(I,0,JV)=ALF(I,0)*S00(JV)
193	ENDIF
194	END DO
195	END DO
196	C
197	C puts the temporary moments Fi into appropriate neighboring boxes
198	C
199	DO I=1,LON
200	C
201	IF(VGRI(I,0,L)>0.) THEN
202	SM(I,1,L)=SM(I,1,L)+FM(I,0)
203	ALF(I,0)=FM(I,0)/SM(I,1,L)
204	ENDIF
205	C
206	ALF1(I,0)=1.-ALF(I,0)
207	C
208	END DO
209	C
210	DO JV=1,NTRA
211	DO I=1,LON
212	C
213	IF(VGRI(I,0,L)>0.) THEN
214	C
215	TEMPTM=ALF(I,0)S0(I,1,L,JV)-ALF1(I,0)F0(I,0,JV)
216	S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
217	sy(I,1,L,JV)=ALF1(I,0)sy(I,1,L,JV)+3.TEMPTM
218	C
219	ENDIF
220	C
221	END DO
222	END DO
223	C
224	C calculate flux and moments between adjacent boxes
225	C 1- create temporary moments/masses for partial boxes in transit
226	C 2- reajusts moments remaining in the box
227	C
228	C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
229	C
230	DO K=1,LAT-1
231	KP=K+1
232	DO I=1,LON
233	C
234	IF(VGRI(I,K,L)<0.) THEN
235	FM(I,K)=-VGRI(I,K,L)*DTY
236	ALF(I,K)=FM(I,K)/SM(I,KP,L)
237	SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
238	ELSE
239	FM(I,K)=VGRI(I,K,L)*DTY
240	ALF(I,K)=FM(I,K)/SM(I,K,L)
241	SM(I,K,L)=SM(I,K,L)-FM(I,K)
242	ENDIF
243	C
244	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
245	ALF1(I,K)=1.-ALF(I,K)
246	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
247	C
248	END DO
249	END DO
250	C
251	DO JV=1,NTRA
252	DO K=1,LAT-1
253	KP=K+1
254	DO I=1,LON
255	C
256	IF(VGRI(I,K,L)<0.) THEN
257	C
258	F0(I,K,JV)=ALF (I,K)*
259	+ ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )
260	FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)
261	FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)
262	FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)
263	C
264	S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
265	sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)
266	sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)
267	sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)
268	C
269	ELSE
270	C
271	F0(I,K,JV)=ALF (I,K)*
272	+ ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
273	FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)
274	FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)
275	FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)
276	C
277	S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)
278	sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
279	sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)
280	sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)
281	C
282	ENDIF
283	C
284	END DO
285	END DO
286	END DO
287	C
288	C puts the temporary moments Fi into appropriate neighboring boxes
289	C
290	DO K=1,LAT-1
291	KP=K+1
292	DO I=1,LON
293	C
294	IF(VGRI(I,K,L)<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	END DO
305	END DO
306	C
307	DO JV=1,NTRA
308	DO K=1,LAT-1
309	KP=K+1
310	DO I=1,LON
311	C
312	IF(VGRI(I,K,L)<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	END DO
333	END DO
334	END DO
335	C
336	C traitement special pour le pole Sud (idem pole Nord)
337	C
338	K=LAT
339	C
340	SM0=0.
341	DO JV=1,NTRA
342	S00(JV)=0.
343	END DO
344	C
345	DO I=1,LON
346	C
347	IF(VGRI(I,K,L)>=0.) THEN
348	FM(I,K)=VGRI(I,K,L)*DTY
349	ALF(I,K)=FM(I,K)/SM(I,K,L)
350	SM(I,K,L)=SM(I,K,L)-FM(I,K)
351	SM0=SM0+FM(I,K)
352	ENDIF
353	C
354	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
355	ALF1(I,K)=1.-ALF(I,K)
356	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
357	C
358	END DO
359	C
360	DO JV=1,NTRA
361	DO I=1,LON
362	C
363	IF(VGRI(I,K,L)>=0.) THEN
364	F0 (I,K,JV)=ALF(I,K)*
365	+ ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
366	S00(JV)=S00(JV)+F0(I,K,JV)
367	C
368	S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
369	sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
370	sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)
371	sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)
372	ENDIF
373	C
374	END DO
375	END DO
376	C
377	DO I=1,LON
378	IF(VGRI(I,K,L)<0.) THEN
379	FM(I,K)=-VGRI(I,K,L)*DTY
380	ALF(I,K)=FM(I,K)/SM0
381	ENDIF
382	END DO
383	C
384	DO JV=1,NTRA
385	DO I=1,LON
386	IF(VGRI(I,K,L)<0.) THEN
387	F0(I,K,JV)=ALF(I,K)*S00(JV)
388	ENDIF
389	END DO
390	END DO
391	C
392	C puts the temporary moments Fi into appropriate neighboring boxes
393	C
394	DO I=1,LON
395	C
396	IF(VGRI(I,K,L)<0.) THEN
397	SM(I,K,L)=SM(I,K,L)+FM(I,K)
398	ALF(I,K)=FM(I,K)/SM(I,K,L)
399	ENDIF
400	C
401	ALF1(I,K)=1.-ALF(I,K)
402	C
403	END DO
404	C
405	DO JV=1,NTRA
406	DO I=1,LON
407	C
408	IF(VGRI(I,K,L)<0.) THEN
409	C
410	TEMPTM=-ALF(I,K)S0(I,K,L,JV)+ALF1(I,K)F0(I,K,JV)
411	S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
412	sy(I,K,L,JV)=ALF1(I,K)sy(I,K,L,JV)+3.TEMPTM
413	C
414	ENDIF
415	C
416	END DO
417	END DO
418	C
419	END DO
420	C
421	RETURN
422	END
423

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

Download in other formats:

Original Format