Context Navigation

advyp.f90 @ 5157

Last change on this file since 5157 was 5136, checked in by abarral, 4 months ago
Put comgeom.h, comgeom2.h into modules
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: 21.4 KB

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

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

Download in other formats:

Original Format