Context Navigation

advyp.F @ 2597

Last change on this file since 2597 was 2597, checked in by Ehouarn Millour, 8 years ago
Cleanup in the dynamics: get rid of comconst.h, make it a module comconst_mod. EM
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: 18.9 KB

Line
1	!
2	! $Header$
3	!
4	SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ
5	. ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
6	IMPLICIT NONE
7	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8	C C
9	C second-order moments (SOM) advection of tracer in Y direction C
10	C C
11	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
12	C C
13	C Source : Pascal Simon ( Meteo, CNRM ) C
14	C Adaptation : A.A. (LGGE) C
15	C Derniere Modif : 19/10/95 LAST
16	C C
17	C sont les arguments d'entree pour le s-pg C
18	C C
19	C argument de sortie du s-pg C
20	C C
21	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
22	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
23	C
24	C Rem : Probleme aux poles il faut reecrire ce cas specifique
25	C Attention au sens de l'indexation
26	C
27	C parametres principaux du modele
28	C
29	C
30	#include "dimensions.h"
31	#include "paramet.h"
32	#include "comvert.h"
33	#include "comgeom.h"
34
35	C Arguments :
36	C ----------
37	C dty : frequence fictive d'appel du transport
38	C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
39
40	INTEGER lon,lat,niv
41	INTEGER i,j,jv,k,kp,l
42	INTEGER ntra
43	C PARAMETER (ntra = 1)
44
45	REAL dty
46	REAL pbarv ( iip1,jjm, llm )
47
48	C moments: SM total mass in each grid box
49	C S0 mass of tracer in each grid box
50	C Si 1rst order moment in i direction
51	C
52	REAL SM(iip1,jjp1,llm)
53	+ ,S0(iip1,jjp1,llm,ntra)
54	REAL SSX(iip1,jjp1,llm,ntra)
55	+ ,SY(iip1,jjp1,llm,ntra)
56	+ ,SZ(iip1,jjp1,llm,ntra)
57	+ ,SSXX(iip1,jjp1,llm,ntra)
58	+ ,SSXY(iip1,jjp1,llm,ntra)
59	+ ,SSXZ(iip1,jjp1,llm,ntra)
60	+ ,SYY(iip1,jjp1,llm,ntra)
61	+ ,SYZ(iip1,jjp1,llm,ntra)
62	+ ,SZZ(iip1,jjp1,llm,ntra)
63	C
64	C Local :
65	C -------
66
67	C mass fluxes across the boundaries (UGRI,VGRI,WGRI)
68	C mass fluxes in kg
69	C declaration :
70
71	REAL VGRI(iip1,0:jjp1,llm)
72
73	C Rem : UGRI et WGRI ne sont pas utilises dans
74	C cette subroutine ( advection en y uniquement )
75	C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
76	C
77	C the moments F are similarly defined and used as temporary
78	C storage for portions of the grid boxes in transit
79	C
80	C the moments Fij are used as temporary storage for
81	C portions of the grid boxes in transit at the current level
82	C
83	C work arrays
84	C
85	C
86	REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
87	REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
88	REAL FZ(iim,jjm,ntra)
89	REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra)
90	REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra)
91	REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra)
92	REAL S00(ntra)
93	REAL SM0 ! Just temporal variable
94	C
95	C work arrays
96	C
97	REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
98	REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
99	REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1)
100	REAL ALF4(iim,0:jjp1)
101	REAL TEMPTM ! Just temporal variable
102	REAL SLPMAX,S1MAX,S1NEW,S2NEW
103	c
104	C Special pour poles
105	c
106	REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
107	REAL sns0(ntra),snsz(ntra),snsm
108	REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
109	REAL cx1(llm,ntra), cxLAT(llm,ntra)
110	REAL cy1(llm,ntra), cyLAT(llm,ntra)
111	REAL z1(iim), zcos(iim), zsin(iim)
112	REAL SSUM
113	EXTERNAL SSUM
114	C
115	REAL sqi,sqf
116	LOGICAL LIMIT
117
118	lon = iim ! rem : Il est possible qu'un pbl. arrive ici
119	lat = jjp1 ! a cause des dim. differentes entre les
120	niv = llm ! tab. S et VGRI
121
122	c-----------------------------------------------------------------
123	C initialisations
124
125	sbms = 0.
126	sfms = 0.
127	sfzs = 0.
128	sbmn = 0.
129	sfmn = 0.
130	sfzn = 0.
131
132	c-----------------------------------------------------------------
133	C *** Test : diag de la qtite totale de traceur dans
134	C l'atmosphere avant l'advection en Y
135	c
136	sqi = 0.
137	sqf = 0.
138
139	DO l = 1,llm
140	DO j = 1,jjp1
141	DO i = 1,iim
142	sqi = sqi + S0(i,j,l,ntra)
143	END DO
144	END DO
145	END DO
146	PRINT*,'---------- DIAG DANS ADVY - ENTREE --------'
147	PRINT*,'sqi=',sqi
148
149	c-----------------------------------------------------------------
150	C Interface : adaptation nouveau modele
151	C -------------------------------------
152	C
153	C Conversion des flux de masses en kg
154	C-AA 20/10/94 le signe -1 est necessaire car indexation opposee
155
156	DO 500 l = 1,llm
157	DO 500 j = 1,jjm
158	DO 500 i = 1,iip1
159	vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l)
160	500 CONTINUE
161
162	CAA Initialisation de flux fictifs aux bords sup. des boites pol.
163
164	DO l = 1,llm
165	DO i = 1,iip1
166	vgri(i,0,l) = 0.
167	vgri(i,jjp1,l) = 0.
168	ENDDO
169	ENDDO
170	c
171	c----------------- START HERE -----------------------
172	C boucle sur les niveaux
173	C
174	DO 1 L=1,NIV
175	C
176	C place limits on appropriate moments before transport
177	C (if flux-limiting is to be applied)
178	C
179	IF(.NOT.LIMIT) GO TO 11
180	C
181	DO 10 JV=1,NTRA
182	DO 10 K=1,LAT
183	DO 100 I=1,LON
184	IF(S0(I,K,L,JV).GT.0.) THEN
185	SLPMAX=AMAX1(S0(I,K,L,JV),0.)
186	S1MAX=1.5*SLPMAX
187	S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV)))
188	S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
189	+ AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) )
190	SY (I,K,L,JV)=S1NEW
191	SYY(I,K,L,JV)=S2NEW
192	SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV)))
193	SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
194	ELSE
195	SY (I,K,L,JV)=0.
196	SYY(I,K,L,JV)=0.
197	SSXY(I,K,L,JV)=0.
198	SYZ(I,K,L,JV)=0.
199	ENDIF
200	100 CONTINUE
201	10 CONTINUE
202	C
203	11 CONTINUE
204	C
205	C le flux a travers le pole Nord est traite separement
206	C
207	SM0=0.
208	DO 20 JV=1,NTRA
209	S00(JV)=0.
210	20 CONTINUE
211	C
212	DO 21 I=1,LON
213	C
214	IF(VGRI(I,0,L).LE.0.) THEN
215	FM(I,0)=-VGRI(I,0,L)*DTY
216	ALF(I,0)=FM(I,0)/SM(I,1,L)
217	SM(I,1,L)=SM(I,1,L)-FM(I,0)
218	SM0=SM0+FM(I,0)
219	ENDIF
220	C
221	ALFQ(I,0)=ALF(I,0)*ALF(I,0)
222	ALF1(I,0)=1.-ALF(I,0)
223	ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
224	ALF2(I,0)=ALF1(I,0)-ALF(I,0)
225	ALF3(I,0)=ALF(I,0)*ALFQ(I,0)
226	ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0)
227	C
228	21 CONTINUE
229	c print*,'ADVYP 21'
230	C
231	DO 22 JV=1,NTRA
232	DO 220 I=1,LON
233	C
234	IF(VGRI(I,0,L).LE.0.) THEN
235	C
236	F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)*
237	+ ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) )
238	C
239	S00(JV)=S00(JV)+F0(I,0,JV)
240	S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
241	SY (I,1,L,JV)=ALF1Q(I,0)*
242	+ (SY(I,1,L,JV)+3.ALF(I,0)SYY(I,1,L,JV))
243	SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV)
244	SSX (I,1,L,JV)=ALF1 (I,0)*
245	+ (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) )
246	SZ (I,1,L,JV)=ALF1 (I,0)*
247	+ (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) )
248	SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV)
249	SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV)
250	SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV)
251	SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV)
252	SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV)
253	C
254	ENDIF
255	C
256	220 CONTINUE
257	22 CONTINUE
258	C
259	DO 23 I=1,LON
260	IF(VGRI(I,0,L).GT.0.) THEN
261	FM(I,0)=VGRI(I,0,L)*DTY
262	ALF(I,0)=FM(I,0)/SM0
263	ENDIF
264	23 CONTINUE
265	C
266	DO 24 JV=1,NTRA
267	DO 240 I=1,LON
268	IF(VGRI(I,0,L).GT.0.) THEN
269	F0(I,0,JV)=ALF(I,0)*S00(JV)
270	ENDIF
271	240 CONTINUE
272	24 CONTINUE
273	C
274	C puts the temporary moments Fi into appropriate neighboring boxes
275	C
276	c print*,'av ADVYP 25'
277	DO 25 I=1,LON
278	C
279	IF(VGRI(I,0,L).GT.0.) THEN
280	SM(I,1,L)=SM(I,1,L)+FM(I,0)
281	ALF(I,0)=FM(I,0)/SM(I,1,L)
282	ENDIF
283	C
284	ALFQ(I,0)=ALF(I,0)*ALF(I,0)
285	ALF1(I,0)=1.-ALF(I,0)
286	ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
287	ALF2(I,0)=ALF1(I,0)-ALF(I,0)
288	ALF3(I,0)=ALF1(I,0)*ALF(I,0)
289	C
290	25 CONTINUE
291	c print*,'av ADVYP 25'
292	C
293	DO 26 JV=1,NTRA
294	DO 260 I=1,LON
295	C
296	IF(VGRI(I,0,L).GT.0.) THEN
297	C
298	TEMPTM=ALF(I,0)S0(I,1,L,JV)-ALF1(I,0)F0(I,0,JV)
299	S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
300	SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV)
301	+ +5.( ALF3 (I,0)SY (I,1,L,JV)-ALF2(I,0)*TEMPTM )
302	SY (I,1,L,JV)=ALF1 (I,0)SY (I,1,L,JV)+3.TEMPTM
303	SSXY(I,1,L,JV)=ALF1 (I,0)SSXY(I,1,L,JV)+3.ALF(I,0)*SSX(I,1,L,JV)
304	SYZ(I,1,L,JV)=ALF1 (I,0)SYZ(I,1,L,JV)+3.ALF(I,0)*SZ(I,1,L,JV)
305	C
306	ENDIF
307	C
308	260 CONTINUE
309	26 CONTINUE
310	C
311	C calculate flux and moments between adjacent boxes
312	C 1- create temporary moments/masses for partial boxes in transit
313	C 2- reajusts moments remaining in the box
314	C
315	C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
316	C
317	c print*,'av ADVYP 30'
318	DO 30 K=1,LAT-1
319	KP=K+1
320	DO 300 I=1,LON
321	C
322	IF(VGRI(I,K,L).LT.0.) THEN
323	FM(I,K)=-VGRI(I,K,L)*DTY
324	ALF(I,K)=FM(I,K)/SM(I,KP,L)
325	SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
326	ELSE
327	FM(I,K)=VGRI(I,K,L)*DTY
328	ALF(I,K)=FM(I,K)/SM(I,K,L)
329	SM(I,K,L)=SM(I,K,L)-FM(I,K)
330	ENDIF
331	C
332	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
333	ALF1(I,K)=1.-ALF(I,K)
334	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
335	ALF2(I,K)=ALF1(I,K)-ALF(I,K)
336	ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
337	ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
338	C
339	300 CONTINUE
340	30 CONTINUE
341	c print*,'ap ADVYP 30'
342	C
343	DO 31 JV=1,NTRA
344	DO 31 K=1,LAT-1
345	KP=K+1
346	DO 310 I=1,LON
347	C
348	IF(VGRI(I,K,L).LT.0.) THEN
349	C
350	F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)*
351	+ ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) )
352	FY (I,K,JV)=ALFQ(I,K)*
353	+ (SY(I,KP,L,JV)-3.ALF1(I,K)SYY(I,KP,L,JV))
354	FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV)
355	FX (I,K,JV)=ALF (I,K)*
356	+ (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV))
357	FZ (I,K,JV)=ALF (I,K)*
358	+ (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV))
359	FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV)
360	FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV)
361	FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV)
362	FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV)
363	FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV)
364	C
365	S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
366	SY (I,KP,L,JV)=ALF1Q(I,K)*
367	+ (SY(I,KP,L,JV)+3.ALF(I,K)SYY(I,KP,L,JV))
368	SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV)
369	SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV)
370	SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV)
371	SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV)
372	SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV)
373	SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV)
374	SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV)
375	SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV)
376	C
377	ELSE
378	C
379	F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
380	+ ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
381	FY (I,K,JV)=ALFQ(I,K)*
382	+ (SY(I,K,L,JV)+3.ALF1(I,K)SYY(I,K,L,JV))
383	FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV)
384	FX (I,K,JV)=ALF (I,K)(SSX(I,K,L,JV)+ALF1(I,K)SSXY(I,K,L,JV))
385	FZ (I,K,JV)=ALF (I,K)(SZ(I,K,L,JV)+ALF1(I,K)SYZ(I,K,L,JV))
386	FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV)
387	FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV)
388	FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV)
389	FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV)
390	FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV)
391	C
392	S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
393	SY (I,K,L,JV)=ALF1Q(I,K)*
394	+ (SY(I,K,L,JV)-3.ALF(I,K)SYY(I,K,L,JV))
395	SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV)
396	SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV)
397	SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV)
398	SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV)
399	SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV)
400	SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV)
401	SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
402	SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
403	C
404	ENDIF
405	C
406	310 CONTINUE
407	31 CONTINUE
408	c print*,'ap ADVYP 31'
409	C
410	C puts the temporary moments Fi into appropriate neighboring boxes
411	C
412	DO 32 K=1,LAT-1
413	KP=K+1
414	DO 320 I=1,LON
415	C
416	IF(VGRI(I,K,L).LT.0.) THEN
417	SM(I,K,L)=SM(I,K,L)+FM(I,K)
418	ALF(I,K)=FM(I,K)/SM(I,K,L)
419	ELSE
420	SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
421	ALF(I,K)=FM(I,K)/SM(I,KP,L)
422	ENDIF
423	C
424	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
425	ALF1(I,K)=1.-ALF(I,K)
426	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
427	ALF2(I,K)=ALF1(I,K)-ALF(I,K)
428	ALF3(I,K)=ALF1(I,K)*ALF(I,K)
429	C
430	320 CONTINUE
431	32 CONTINUE
432	c print*,'ap ADVYP 32'
433	C
434	DO 33 JV=1,NTRA
435	DO 33 K=1,LAT-1
436	KP=K+1
437	DO 330 I=1,LON
438	C
439	IF(VGRI(I,K,L).LT.0.) THEN
440	C
441	TEMPTM=-ALF(I,K)S0(I,K,L,JV)+ALF1(I,K)F0(I,K,JV)
442	S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
443	SYY(I,K,L,JV)=ALFQ(I,K)FYY(I,K,JV)+ALF1Q(I,K)SYY(I,K,L,JV)
444	+ +5.( ALF3(I,K)(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM )
445	SY (I,K,L,JV)=ALF(I,K)FY(I,K,JV)+ALF1(I,K)SY(I,K,L,JV)
446	+ +3.*TEMPTM
447	SSXY(I,K,L,JV)=ALF (I,K)FXY(I,K,JV)+ALF1(I,K)SSXY(I,K,L,JV)
448	+ +3.(ALF1(I,K)FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV))
449	SYZ(I,K,L,JV)=ALF (I,K)FYZ(I,K,JV)+ALF1(I,K)SYZ(I,K,L,JV)
450	+ +3.(ALF1(I,K)FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV))
451	SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV)
452	SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV)
453	SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV)
454	SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV)
455	SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV)
456	C
457	ELSE
458	C
459	TEMPTM=ALF(I,K)S0(I,KP,L,JV)-ALF1(I,K)F0(I,K,JV)
460	S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
461	SYY(I,KP,L,JV)=ALFQ(I,K)FYY(I,K,JV)+ALF1Q(I,K)SYY(I,KP,L,JV)
462	+ +5.( ALF3(I,K)(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM )
463	SY (I,KP,L,JV)=ALF(I,K)FY(I,K,JV)+ALF1(I,K)SY(I,KP,L,JV)
464	+ +3.*TEMPTM
465	SSXY(I,KP,L,JV)=ALF(I,K)FXY(I,K,JV)+ALF1(I,K)SSXY(I,KP,L,JV)
466	+ +3.(ALF(I,K)SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV))
467	SYZ(I,KP,L,JV)=ALF(I,K)FYZ(I,K,JV)+ALF1(I,K)SYZ(I,KP,L,JV)
468	+ +3.(ALF(I,K)SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV))
469	SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV)
470	SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV)
471	SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV)
472	SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV)
473	SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV)
474	C
475	ENDIF
476	C
477	330 CONTINUE
478	33 CONTINUE
479	c print*,'ap ADVYP 33'
480	C
481	C traitement special pour le pole Sud (idem pole Nord)
482	C
483	K=LAT
484	C
485	SM0=0.
486	DO 40 JV=1,NTRA
487	S00(JV)=0.
488	40 CONTINUE
489	C
490	DO 41 I=1,LON
491	C
492	IF(VGRI(I,K,L).GE.0.) THEN
493	FM(I,K)=VGRI(I,K,L)*DTY
494	ALF(I,K)=FM(I,K)/SM(I,K,L)
495	SM(I,K,L)=SM(I,K,L)-FM(I,K)
496	SM0=SM0+FM(I,K)
497	ENDIF
498	C
499	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
500	ALF1(I,K)=1.-ALF(I,K)
501	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
502	ALF2(I,K)=ALF1(I,K)-ALF(I,K)
503	ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
504	ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
505	C
506	41 CONTINUE
507	c print*,'ap ADVYP 41'
508	C
509	DO 42 JV=1,NTRA
510	DO 420 I=1,LON
511	C
512	IF(VGRI(I,K,L).GE.0.) THEN
513	F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
514	+ ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
515	S00(JV)=S00(JV)+F0(I,K,JV)
516	C
517	S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
518	SY (I,K,L,JV)=ALF1Q(I,K)*
519	+ (SY(I,K,L,JV)-3.ALF(I,K)SYY(I,K,L,JV))
520	SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV)
521	SSX (I,K,L,JV)=ALF1(I,K)(SSX(I,K,L,JV)-ALF(I,K)SSXY(I,K,L,JV))
522	SZ (I,K,L,JV)=ALF1(I,K)(SZ(I,K,L,JV)-ALF(I,K)SYZ(I,K,L,JV))
523	SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV)
524	SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV)
525	SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV)
526	SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
527	SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
528	ENDIF
529	C
530	420 CONTINUE
531	42 CONTINUE
532	c print*,'ap ADVYP 42'
533	C
534	DO 43 I=1,LON
535	IF(VGRI(I,K,L).LT.0.) THEN
536	FM(I,K)=-VGRI(I,K,L)*DTY
537	ALF(I,K)=FM(I,K)/SM0
538	ENDIF
539	43 CONTINUE
540	c print*,'ap ADVYP 43'
541	C
542	DO 44 JV=1,NTRA
543	DO 440 I=1,LON
544	IF(VGRI(I,K,L).LT.0.) THEN
545	F0(I,K,JV)=ALF(I,K)*S00(JV)
546	ENDIF
547	440 CONTINUE
548	44 CONTINUE
549	C
550	C puts the temporary moments Fi into appropriate neighboring boxes
551	C
552	DO 45 I=1,LON
553	C
554	IF(VGRI(I,K,L).LT.0.) THEN
555	SM(I,K,L)=SM(I,K,L)+FM(I,K)
556	ALF(I,K)=FM(I,K)/SM(I,K,L)
557	ENDIF
558	C
559	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
560	ALF1(I,K)=1.-ALF(I,K)
561	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
562	ALF2(I,K)=ALF1(I,K)-ALF(I,K)
563	ALF3(I,K)=ALF1(I,K)*ALF(I,K)
564	C
565	45 CONTINUE
566	c print*,'ap ADVYP 45'
567	C
568	DO 46 JV=1,NTRA
569	DO 460 I=1,LON
570	C
571	IF(VGRI(I,K,L).LT.0.) THEN
572	C
573	TEMPTM=-ALF(I,K)S0(I,K,L,JV)+ALF1(I,K)F0(I,K,JV)
574	S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
575	SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV)
576	+ +5.(-ALF3 (I,K)SY (I,K,L,JV)+ALF2(I,K)*TEMPTM )
577	SY (I,K,L,JV)=ALF1(I,K)SY (I,K,L,JV)+3.TEMPTM
578	SSXY(I,K,L,JV)=ALF1(I,K)SSXY(I,K,L,JV)-3.ALF(I,K)*SSX(I,K,L,JV)
579	SYZ(I,K,L,JV)=ALF1(I,K)SYZ(I,K,L,JV)-3.ALF(I,K)*SZ(I,K,L,JV)
580	C
581	ENDIF
582	C
583	460 CONTINUE
584	46 CONTINUE
585	c print*,'ap ADVYP 46'
586	C
587	1 CONTINUE
588
589	c--------------------------------------------------
590	C bouclage cyclique horizontal .
591
592	DO l = 1,llm
593	DO jv = 1,ntra
594	DO j = 1,jjp1
595	SM(iip1,j,l) = SM(1,j,l)
596	S0(iip1,j,l,jv) = S0(1,j,l,jv)
597	SSX(iip1,j,l,jv) = SSX(1,j,l,jv)
598	SY(iip1,j,l,jv) = SY(1,j,l,jv)
599	SZ(iip1,j,l,jv) = SZ(1,j,l,jv)
600	END DO
601	END DO
602	END DO
603
604	c -------------------------------------------------------------------
605	C *** Test negativite:
606
607	c DO jv = 1,ntra
608	c DO l = 1,llm
609	c DO j = 1,jjp1
610	c DO i = 1,iip1
611	c IF (s0( i,j,l,jv ).lt.0.) THEN
612	c PRINT*, '------ S0 < 0 en FIN ADVYP ---'
613	c PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv)
614	cc STOP
615	c ENDIF
616	c ENDDO
617	c ENDDO
618	c ENDDO
619	c ENDDO
620
621
622	c -------------------------------------------------------------------
623	C *** Test : diag de la qtite totale de traceur dans
624	C l'atmosphere avant l'advection en Y
625
626	DO l = 1,llm
627	DO j = 1,jjp1
628	DO i = 1,iim
629	sqf = sqf + S0(i,j,l,ntra)
630	END DO
631	END DO
632	END DO
633	PRINT*,'---------- DIAG DANS ADVY - SORTIE --------'
634	PRINT*,'sqf=',sqf
635	c print*,'ap ADVYP fin'
636
637	c-----------------------------------------------------------------
638	C
639	RETURN
640	END
641
642
643
644
645
646
647
648
649
650
651
652

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

Download in other formats:

Original Format