Context Navigation

advz.F @ 1907

Last change on this file since 1907 was 1907, checked in by lguez, 10 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
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

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

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: 9.0 KB

Line
1	!
2	! $Header$
3	!
4	SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz)
5	IMPLICIT NONE
6
7	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8	C C
9	C first-order moments (FOM) advection of tracer in Z direction C
10	C C
11	C Source : Pascal Simon (Meteo,CNRM) C
12	C Adaptation : A.Armengaud (LGGE) juin 94 C
13	C C
14	C C
15	C sont des arguments d'entree pour le s-pg... C
16	C C
17	C dq est l'argument de sortie pour le s-pg C
18	C C
19	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
20	C
21	C parametres principaux du modele
22	C
23	#include "dimensions.h"
24	#include "paramet.h"
25	#include "comconst.h"
26	#include "comvert.h"
27
28	C #include "traceur.h"
29
30	C Arguments :
31	C -----------
32	C dtz : frequence fictive d'appel du transport
33	C w : flux de masse en z en Pa.m2.s-1
34
35	INTEGER ntra
36	PARAMETER (ntra = 1)
37
38	REAL dtz
39	REAL w ( iip1,jjp1,llm )
40
41	C moments: SM total mass in each grid box
42	C S0 mass of tracer in each grid box
43	C Si 1rst order moment in i direction
44	C
45	REAL SM(iip1,jjp1,llm)
46	+ ,S0(iip1,jjp1,llm,ntra)
47	REAL sx(iip1,jjp1,llm,ntra)
48	+ ,sy(iip1,jjp1,llm,ntra)
49	+ ,sz(iip1,jjp1,llm,ntra)
50
51
52	C Local :
53	C -------
54
55	C mass fluxes across the boundaries (UGRI,VGRI,WGRI)
56	C mass fluxes in kg
57	C declaration :
58
59	REAL WGRI(iip1,jjp1,0:llm)
60
61	C
62	C the moments F are used as temporary storage for
63	C portions of grid boxes in transit at the current latitude
64	C
65	REAL FM(iim,llm)
66	REAL F0(iim,llm,ntra),FX(iim,llm,ntra)
67	REAL FY(iim,llm,ntra),FZ(iim,llm,ntra)
68	C
69	C work arrays
70	C
71	REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
72	REAL TEMPTM ! Just temporal variable
73	REAL sqi,sqf
74	C
75	LOGICAL LIMIT
76	INTEGER lon,lat,niv
77	INTEGER i,j,jv,k,l,lp
78
79	lon = iim
80	lat = jjp1
81	niv = llm
82
83	C * Test de passage d'arguments ****
84
85	c DO 399 l = 1, llm
86	c DO 399 j = 1, jjp1
87	c DO 399 i = 1, iip1
88	c IF (S0(i,j,l,ntra) .lt. 0. ) THEN
89	c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
90	c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
91	c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
92	c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
93	c PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ'
94	c STOP
95	c ENDIF
96	399 CONTINUE
97
98	C-----------------------------------------------------------------
99	C *** Test : diag de la qqtite totale de traceur
100	C dans l'atmosphere avant l'advection en z
101	sqi = 0.
102	sqf = 0.
103
104	DO l = 1,llm
105	DO j = 1,jjp1
106	DO i = 1,iim
107	cIM 240305 sqi = sqi + S0(i,j,l,9)
108	sqi = sqi + S0(i,j,l,ntra)
109	ENDDO
110	ENDDO
111	ENDDO
112	PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------'
113	PRINT*,'sqi=',sqi
114
115	C-----------------------------------------------------------------
116	C Interface : adaptation nouveau modele
117	C -------------------------------------
118	C
119	C Conversion du flux de masse en kg.s-1
120
121	DO 500 l = 1,llm
122	DO 500 j = 1,jjp1
123	DO 500 i = 1,iip1
124	c wgri (i,j,llm+1-l) = w (i,j,l) / g
125	wgri (i,j,llm+1-l) = w (i,j,l)
126	c wgri (i,j,0) = 0. ! a detruire ult.
127	c wgri (i,j,l) = 0.1 ! w (i,j,l)
128	c wgri (i,j,llm) = 0. ! a detruire ult.
129	500 CONTINUE
130	DO j = 1,jjp1
131	DO i = 1,iip1
132	wgri(i,j,0)=0.
133	enddo
134	enddo
135
136	C-----------------------------------------------------------------
137
138	C start here
139	C boucle sur les latitudes
140	C
141	DO 1 K=1,LAT
142	C
143	C place limits on appropriate moments before transport
144	C (if flux-limiting is to be applied)
145	C
146	IF(.NOT.LIMIT) GO TO 101
147	C
148	DO 10 JV=1,NTRA
149	DO 10 L=1,NIV
150	DO 100 I=1,LON
151	sz(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),
152	+ ABS(sz(I,K,L,JV))),sz(I,K,L,JV))
153	100 CONTINUE
154	10 CONTINUE
155	C
156	101 CONTINUE
157	C
158	C boucle sur les niveaux intercouches de 1 a NIV-1
159	C (flux nul au sommet L=0 et a la base L=NIV)
160	C
161	C calculate flux and moments between adjacent boxes
162	C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
163	C 1- create temporary moments/masses for partial boxes in transit
164	C 2- reajusts moments remaining in the box
165	C
166	DO 11 L=1,NIV-1
167	LP=L+1
168	C
169	DO 110 I=1,LON
170	C
171	IF(WGRI(I,K,L).LT.0.) THEN
172	FM(I,L)=-WGRI(I,K,L)*DTZ
173	ALF(I)=FM(I,L)/SM(I,K,LP)
174	SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
175	ELSE
176	FM(I,L)=WGRI(I,K,L)*DTZ
177	ALF(I)=FM(I,L)/SM(I,K,L)
178	SM(I,K,L)=SM(I,K,L)-FM(I,L)
179	ENDIF
180	C
181	ALFQ (I)=ALF(I)*ALF(I)
182	ALF1 (I)=1.-ALF(I)
183	ALF1Q(I)=ALF1(I)*ALF1(I)
184	C
185	110 CONTINUE
186	C
187	DO 111 JV=1,NTRA
188	DO 1110 I=1,LON
189	C
190	IF(WGRI(I,K,L).LT.0.) THEN
191	C
192	F0(I,L,JV)=ALF (I)( S0(I,K,LP,JV)-ALF1(I)sz(I,K,LP,JV) )
193	FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV)
194	FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV)
195	FY(I,L,JV)=ALF (I)*sy(I,K,LP,JV)
196	C
197	S0(I,K,LP,JV)=S0(I,K,LP,JV)-F0(I,L,JV)
198	sz(I,K,LP,JV)=ALF1Q(I)*sz(I,K,LP,JV)
199	sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV)
200	sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV)
201	C
202	ELSE
203	C
204	F0(I,L,JV)=ALF (I)(S0(I,K,L,JV)+ALF1(I)sz(I,K,L,JV) )
205	FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV)
206	FX(I,L,JV)=ALF (I)*sx(I,K,L,JV)
207	FY(I,L,JV)=ALF (I)*sy(I,K,L,JV)
208	C
209	S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,L,JV)
210	sz(I,K,L,JV)=ALF1Q(I)*sz(I,K,L,JV)
211	sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV)
212	sy(I,K,L,JV)=sy(I,K,L,JV)-FY(I,L,JV)
213	C
214	ENDIF
215	C
216	1110 CONTINUE
217	111 CONTINUE
218	C
219	11 CONTINUE
220	C
221	C puts the temporary moments Fi into appropriate neighboring boxes
222	C
223	DO 12 L=1,NIV-1
224	LP=L+1
225	C
226	DO 120 I=1,LON
227	C
228	IF(WGRI(I,K,L).LT.0.) THEN
229	SM(I,K,L)=SM(I,K,L)+FM(I,L)
230	ALF(I)=FM(I,L)/SM(I,K,L)
231	ELSE
232	SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
233	ALF(I)=FM(I,L)/SM(I,K,LP)
234	ENDIF
235	C
236	ALF1(I)=1.-ALF(I)
237	ALFQ(I)=ALF(I)*ALF(I)
238	ALF1Q(I)=ALF1(I)*ALF1(I)
239	C
240	120 CONTINUE
241	C
242	DO 121 JV=1,NTRA
243	DO 1210 I=1,LON
244	C
245	IF(WGRI(I,K,L).LT.0.) THEN
246	C
247	TEMPTM=-ALF(I)S0(I,K,L,JV)+ALF1(I)F0(I,L,JV)
248	S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
249	sz(I,K,L,JV)=ALF(I)FZ(I,L,JV)+ALF1(I)sz(I,K,L,JV)+3.*TEMPTM
250	sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV)
251	sy(I,K,L,JV)=sy(I,K,L,JV)+FY(I,L,JV)
252	C
253	ELSE
254	C
255	TEMPTM=ALF(I)S0(I,K,LP,JV)-ALF1(I)F0(I,L,JV)
256	S0(I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
257	sz(I,K,LP,JV)=ALF(I)FZ(I,L,JV)+ALF1(I)sz(I,K,LP,JV)
258	+ +3.*TEMPTM
259	sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV)
260	sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(I,L,JV)
261	C
262	ENDIF
263	C
264	1210 CONTINUE
265	121 CONTINUE
266	C
267	12 CONTINUE
268	C
269	C fin de la boucle principale sur les latitudes
270	C
271	1 CONTINUE
272	C
273	C-------------------------------------------------------------
274	C
275	C ----------- AA Test en fin de ADVX ------ Controle des S*
276
277	c DO 9999 l = 1, llm
278	c DO 9999 j = 1, jjp1
279	c DO 9999 i = 1, iip1
280	c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
281	c PRINT*, '-------------------'
282	c PRINT*, 'En fin de ADVZ'
283	c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
284	c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
285	c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
286	c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
287	c WRITE (,) 'On arrete !! - pbl en fin de ADVZ1'
288	c STOP
289	c ENDIF
290	9999 CONTINUE
291
292	C *** ------------------- bouclage cyclique en X ------------
293
294	c DO l = 1,llm
295	c DO j = 1,jjp1
296	c SM(iip1,j,l) = SM(1,j,l)
297	c S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
298	C sx(iip1,j,l,ntra) = sx(1,j,l,ntra)
299	c sy(iip1,j,l,ntra) = sy(1,j,l,ntra)
300	c sz(iip1,j,l,ntra) = sz(1,j,l,ntra)
301	c ENDDO
302	c ENDDO
303
304	C-------------------------------------------------------------
305	C *** Test : diag de la qqtite totale de traceur
306	C dans l'atmosphere avant l'advection en z
307	DO l = 1,llm
308	DO j = 1,jjp1
309	DO i = 1,iim
310	cIM 240305 sqf = sqf + S0(i,j,l,9)
311	sqf = sqf + S0(i,j,l,ntra)
312	ENDDO
313	ENDDO
314	ENDDO
315	PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
316	PRINT*,'sqf=', sqf
317
318	C-------------------------------------------------------------
319	RETURN
320	END
321	C_______________________________________________________________
322	C_______________________________________________________________

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

Download in other formats:

Original Format