Context Navigation

advzp.F @ 3000

Last change on this file since 3000 was 1422, checked in by milmd, 10 years ago
In GENERIC, MARS and COMMON models replace some include files by modules (usefull for decoupling physics with dynamics).
File size: 12.1 KB

Line
1	!
2	! $Header$
3	!
4	SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ
5	. ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
6
7	IMPLICIT NONE
8
9	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10	C C
11	C second-order moments (SOM) advection of tracer in Z direction C
12	C C
13	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
14	C C
15	C Source : Pascal Simon ( Meteo, CNRM ) C
16	C Adaptation : A.A. (LGGE) C
17	C Derniere Modif : 19/11/95 LAST C
18	C C
19	C sont les arguments d'entree pour le s-pg C
20	C C
21	C argument de sortie du s-pg C
22	C C
23	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
24	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
25	C
26	C Rem : Probleme aux poles il faut reecrire ce cas specifique
27	C Attention au sens de l'indexation
28	C
29
30	C
31	C parametres principaux du modele
32	C
33	#include "dimensions.h"
34	#include "paramet.h"
35	#include "comgeom.h"
36	C
37	C Arguments :
38	C ----------
39	C dty : frequence fictive d'appel du transport
40	C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
41	c
42	INTEGER lon,lat,niv
43	INTEGER i,j,jv,k,kp,l,lp
44	INTEGER ntra
45	c PARAMETER (ntra = 1)
46	c
47	REAL dtz
48	REAL w ( iip1,jjp1,llm )
49	c
50	C moments: SM total mass in each grid box
51	C S0 mass of tracer in each grid box
52	C Si 1rst order moment in i direction
53	C
54	REAL SM(iip1,jjp1,llm)
55	+ ,S0(iip1,jjp1,llm,ntra)
56	REAL SSX(iip1,jjp1,llm,ntra)
57	+ ,SY(iip1,jjp1,llm,ntra)
58	+ ,SZ(iip1,jjp1,llm,ntra)
59	+ ,SSXX(iip1,jjp1,llm,ntra)
60	+ ,SSXY(iip1,jjp1,llm,ntra)
61	+ ,SSXZ(iip1,jjp1,llm,ntra)
62	+ ,SYY(iip1,jjp1,llm,ntra)
63	+ ,SYZ(iip1,jjp1,llm,ntra)
64	+ ,SZZ(iip1,jjp1,llm,ntra)
65	C
66	C Local :
67	C -------
68	C
69	C mass fluxes across the boundaries (UGRI,VGRI,WGRI)
70	C mass fluxes in kg
71	C declaration :
72	C
73	REAL WGRI(iip1,jjp1,0:llm)
74
75	C Rem : UGRI et VGRI ne sont pas utilises dans
76	C cette subroutine ( advection en z uniquement )
77	C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
78	C attention a celui de WGRI
79	C
80	C the moments F are similarly defined and used as temporary
81	C storage for portions of the grid boxes in transit
82	C
83	C the moments Fij are used as temporary storage for
84	C portions of the grid boxes in transit at the current level
85	C
86	C work arrays
87	C
88	C
89	REAL F0(iim,llm,ntra),FM(iim,llm)
90	REAL FX(iim,llm,ntra),FY(iim,llm,ntra)
91	REAL FZ(iim,llm,ntra)
92	REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra)
93	REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra)
94	REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra)
95	REAL S00(ntra)
96	REAL SM0 ! Just temporal variable
97	C
98	C work arrays
99	C
100	REAL ALF(iim),ALF1(iim)
101	REAL ALFQ(iim),ALF1Q(iim)
102	REAL ALF2(iim),ALF3(iim)
103	REAL ALF4(iim)
104	REAL TEMPTM ! Just temporal variable
105	REAL SLPMAX,S1MAX,S1NEW,S2NEW
106	c
107	REAL sqi,sqf
108	LOGICAL LIMIT
109
110	lon = iim ! rem : Il est possible qu'un pbl. arrive ici
111	lat = jjp1 ! a cause des dim. differentes entre les
112	niv = llm ! tab. S et VGRI
113
114	c-----------------------------------------------------------------
115	C *** Test : diag de la qtite totale de traceur dans
116	C l'atmosphere avant l'advection en Y
117	c
118	sqi = 0.
119	sqf = 0.
120	c
121	DO l = 1,llm
122	DO j = 1,jjp1
123	DO i = 1,iim
124	sqi = sqi + S0(i,j,l,ntra)
125	END DO
126	END DO
127	END DO
128	PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------'
129	PRINT*,'sqi=',sqi
130
131	c-----------------------------------------------------------------
132	C Interface : adaptation nouveau modele
133	C -------------------------------------
134	C
135	C Conversion des flux de masses en kg
136
137	DO 500 l = 1,llm
138	DO 500 j = 1,jjp1
139	DO 500 i = 1,iip1
140	wgri (i,j,llm+1-l) = w (i,j,l)
141	500 CONTINUE
142	do j=1,jjp1
143	do i=1,iip1
144	wgri(i,j,0)=0.
145	enddo
146	enddo
147	c
148	cAA rem : Je ne suis pas sur du signe
149	cAA Je ne suis pas sur pour le 0:llm
150	c
151	c-----------------------------------------------------------------
152	C---------------------- START HERE -------------------------------
153	C
154	C boucle sur les latitudes
155	C
156	DO 1 K=1,LAT
157	C
158	C place limits on appropriate moments before transport
159	C (if flux-limiting is to be applied)
160	C
161	IF(.NOT.LIMIT) GO TO 101
162	C
163	DO 10 JV=1,NTRA
164	DO 10 L=1,NIV
165	DO 100 I=1,LON
166	IF(S0(I,K,L,JV).GT.0.) THEN
167	SLPMAX=S0(I,K,L,JV)
168	S1MAX =1.5*SLPMAX
169	S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV)))
170	S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
171	+ AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) )
172	SZ (I,K,L,JV)=S1NEW
173	SZZ(I,K,L,JV)=S2NEW
174	SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV)))
175	SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
176	ELSE
177	SZ (I,K,L,JV)=0.
178	SZZ(I,K,L,JV)=0.
179	SSXZ(I,K,L,JV)=0.
180	SYZ(I,K,L,JV)=0.
181	ENDIF
182	100 CONTINUE
183	10 CONTINUE
184	C
185	101 CONTINUE
186	C
187	C boucle sur les niveaux intercouches de 1 a NIV-1
188	C (flux nul au sommet L=0 et a la base L=NIV)
189	C
190	C calculate flux and moments between adjacent boxes
191	C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
192	C 1- create temporary moments/masses for partial boxes in transit
193	C 2- reajusts moments remaining in the box
194	C
195	DO 11 L=1,NIV-1
196	LP=L+1
197	C
198	DO 110 I=1,LON
199	C
200	IF(WGRI(I,K,L).LT.0.) THEN
201	FM(I,L)=-WGRI(I,K,L)*DTZ
202	ALF(I)=FM(I,L)/SM(I,K,LP)
203	SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
204	ELSE
205	FM(I,L)=WGRI(I,K,L)*DTZ
206	ALF(I)=FM(I,L)/SM(I,K,L)
207	SM(I,K,L)=SM(I,K,L)-FM(I,L)
208	ENDIF
209	C
210	ALFQ (I)=ALF(I)*ALF(I)
211	ALF1 (I)=1.-ALF(I)
212	ALF1Q(I)=ALF1(I)*ALF1(I)
213	ALF2 (I)=ALF1(I)-ALF(I)
214	ALF3 (I)=ALF(I)*ALFQ(I)
215	ALF4 (I)=ALF1(I)*ALF1Q(I)
216	C
217	110 CONTINUE
218	C
219	DO 111 JV=1,NTRA
220	DO 1110 I=1,LON
221	C
222	IF(WGRI(I,K,L).LT.0.) THEN
223	C
224	F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)*
225	+ ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) )
226	FZ (I,L,JV)=ALFQ(I)(SZ(I,K,LP,JV)-3.ALF1(I)*SZZ(I,K,LP,JV))
227	FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV)
228	FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV)
229	FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV)
230	FX (I,L,JV)=ALF (I)(SSX(I,K,LP,JV)-ALF1(I)SSXZ(I,K,LP,JV))
231	FY (I,L,JV)=ALF (I)(SY(I,K,LP,JV)-ALF1(I)SYZ(I,K,LP,JV))
232	FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV)
233	FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV)
234	FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV)
235	C
236	S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV)
237	SZ (I,K,LP,JV)=ALF1Q(I)
238	+ (SZ(I,K,LP,JV)+3.ALF(I)*SZZ(I,K,LP,JV))
239	SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV)
240	SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV)
241	SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV)
242	SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV)
243	SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV)
244	SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV)
245	SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV)
246	SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV)
247	C
248	ELSE
249	C
250	F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV)
251	+ +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) )
252	FZ (I,L,JV)=ALFQ(I)(SZ(I,K,L,JV)+3.ALF1(I)*SZZ(I,K,L,JV))
253	FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV)
254	FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV)
255	FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV)
256	FX (I,L,JV)=ALF (I)(SSX(I,K,L,JV)+ALF1(I)SSXZ(I,K,L,JV))
257	FY (I,L,JV)=ALF (I)(SY(I,K,L,JV)+ALF1(I)SYZ(I,K,L,JV))
258	FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV)
259	FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV)
260	FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV)
261	C
262	S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV)
263	SZ (I,K,L,JV)=ALF1Q(I)(SZ(I,K,L,JV)-3.ALF(I)*SZZ(I,K,L,JV))
264	SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV)
265	SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV)
266	SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV)
267	SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV)
268	SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV)
269	SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV)
270	SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV)
271	SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV)
272	C
273	ENDIF
274	C
275	1110 CONTINUE
276	111 CONTINUE
277	C
278	11 CONTINUE
279	C
280	C puts the temporary moments Fi into appropriate neighboring boxes
281	C
282	DO 12 L=1,NIV-1
283	LP=L+1
284	C
285	DO 120 I=1,LON
286	C
287	IF(WGRI(I,K,L).LT.0.) THEN
288	SM(I,K,L)=SM(I,K,L)+FM(I,L)
289	ALF(I)=FM(I,L)/SM(I,K,L)
290	ELSE
291	SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
292	ALF(I)=FM(I,L)/SM(I,K,LP)
293	ENDIF
294	C
295	ALF1(I)=1.-ALF(I)
296	ALFQ(I)=ALF(I)*ALF(I)
297	ALF1Q(I)=ALF1(I)*ALF1(I)
298	ALF2(I)=ALF(I)*ALF1(I)
299	ALF3(I)=ALF1(I)-ALF(I)
300	C
301	120 CONTINUE
302	C
303	DO 121 JV=1,NTRA
304	DO 1210 I=1,LON
305	C
306	IF(WGRI(I,K,L).LT.0.) THEN
307	C
308	TEMPTM=-ALF(I)S0(I,K,L,JV)+ALF1(I)F0(I,L,JV)
309	S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
310	SZZ(I,K,L,JV)=ALFQ(I)FZZ(I,L,JV)+ALF1Q(I)SZZ(I,K,L,JV)
311	+ +5.( ALF2(I)(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM )
312	SZ (I,K,L,JV)=ALF (I)FZ (I,L,JV)+ALF1 (I)SZ (I,K,L,JV)
313	+ +3.*TEMPTM
314	SSXZ(I,K,L,JV)=ALF (I)FXZ(I,L,JV)+ALF1 (I)SSXZ(I,K,L,JV)
315	+ +3.(ALF1(I)FX (I,L,JV)-ALF (I)*SSX (I,K,L,JV))
316	SYZ(I,K,L,JV)=ALF (I)FYZ(I,L,JV)+ALF1 (I)SYZ(I,K,L,JV)
317	+ +3.(ALF1(I)FY (I,L,JV)-ALF (I)*SY (I,K,L,JV))
318	SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV)
319	SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV)
320	SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV)
321	SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV)
322	SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV)
323	C
324	ELSE
325	C
326	TEMPTM=ALF(I)S0(I,K,LP,JV)-ALF1(I)F0(I,L,JV)
327	S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
328	SZZ(I,K,LP,JV)=ALFQ(I)FZZ(I,L,JV)+ALF1Q(I)SZZ(I,K,LP,JV)
329	+ +5.( ALF2(I)(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM )
330	SZ (I,K,LP,JV)=ALF (I)FZ(I,L,JV)+ALF1(I)SZ(I,K,LP,JV)
331	+ +3.*TEMPTM
332	SSXZ(I,K,LP,JV)=ALF(I)FXZ(I,L,JV)+ALF1(I)SSXZ(I,K,LP,JV)
333	+ +3.(ALF(I)SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV))
334	SYZ(I,K,LP,JV)=ALF(I)FYZ(I,L,JV)+ALF1(I)SYZ(I,K,LP,JV)
335	+ +3.(ALF(I)SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV))
336	SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV)
337	SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV)
338	SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV)
339	SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV)
340	SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV)
341	C
342	ENDIF
343	C
344	1210 CONTINUE
345	121 CONTINUE
346	C
347	12 CONTINUE
348	C
349	C fin de la boucle principale sur les latitudes
350	C
351	1 CONTINUE
352	C
353	DO l = 1,llm
354	DO j = 1,jjp1
355	SM(iip1,j,l) = SM(1,j,l)
356	S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
357	SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
358	SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
359	SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
360	ENDDO
361	ENDDO
362	c C-------------------------------------------------------------
363	C *** Test : diag de la qqtite totale de tarceur
364	C dans l'atmosphere avant l'advection en z
365	DO l = 1,llm
366	DO j = 1,jjp1
367	DO i = 1,iim
368	sqf = sqf + S0(i,j,l,ntra)
369	ENDDO
370	ENDDO
371	ENDDO
372	PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
373	PRINT*,'sqf=', sqf
374
375	RETURN
376	END

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

Download in other formats:

Original Format