Context Navigation

advyp.F @ 5434

Last change on this file since 5434 was 1632, checked in by Laurent Fairhead, 13 years ago

Import initial du répertoire dyn3dmem

Attention! ceci n'est qu'une version préliminaire du code "basse mémoire":
le code contenu dans ce répertoire est basé sur la r1320 et a donc besoin
d'être mis à jour par rapport à la dynamique parallèle d'aujourd'hui.
Ce code est toutefois mis à disposition pour circonvenir à des problèmes
de mémoire que certaines configurations du modèle pourraient rencontrer.
Dans l'état, il compile et tourne sur vargas et au CCRT

Initial import of dyn3dmem

Warning! this is just a preliminary version of the memory light code:
it is based on r1320 of the code and thus needs to be updated before
it can replace the present dyn3dpar code. It is nevertheless put at your
disposal to circumvent some memory problems some LMDZ configurations may
encounter. In its present state, it will compile and run on vargas and CCRT

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

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

Download in other formats:

Original Format