Context Navigation

advz.F @ 5099

Last change on this file since 5099 was 5099, checked in by abarral, 4 months ago
Replace most uses of CPP_DUST by the corresponding logical defined in lmdz_cppkeys_wrapper.F90 Convert several files from .F to .f90 to allow Dust to compile w/o rrtm/ecrad Create lmdz_yoerad.f90 (lint) Remove "!" on otherwise empty line
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: 8.9 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
26	C INCLUDE "traceur.h"
27
28	C Arguments :
29	C -----------
30	C dtz : frequence fictive d'appel du transport
31	C w : flux de masse en z en Pa.m2.s-1
32
33	INTEGER ntra
34	PARAMETER (ntra = 1)
35
36	REAL dtz
37	REAL w ( iip1,jjp1,llm )
38
39	C moments: SM total mass in each grid box
40	C S0 mass of tracer in each grid box
41	C Si 1rst order moment in i direction
42	C
43	REAL SM(iip1,jjp1,llm)
44	+ ,S0(iip1,jjp1,llm,ntra)
45	REAL sx(iip1,jjp1,llm,ntra)
46	+ ,sy(iip1,jjp1,llm,ntra)
47	+ ,sz(iip1,jjp1,llm,ntra)
48
49
50	C Local :
51	C -------
52
53	C mass fluxes across the boundaries (UGRI,VGRI,WGRI)
54	C mass fluxes in kg
55	C declaration :
56
57	REAL WGRI(iip1,jjp1,0:llm)
58
59	C
60	C the moments F are used as temporary storage for
61	C portions of grid boxes in transit at the current latitude
62	C
63	REAL FM(iim,llm)
64	REAL F0(iim,llm,ntra),FX(iim,llm,ntra)
65	REAL FY(iim,llm,ntra),FZ(iim,llm,ntra)
66	C
67	C work arrays
68	C
69	REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
70	REAL TEMPTM ! Just temporal variable
71	REAL sqi,sqf
72	C
73	LOGICAL LIMIT
74	INTEGER lon,lat,niv
75	INTEGER i,j,jv,k,l,lp
76
77	lon = iim
78	lat = jjp1
79	niv = llm
80
81	C * Test de passage d'arguments ****
82
83	c DO 399 l = 1, llm
84	c DO 399 j = 1, jjp1
85	c DO 399 i = 1, iip1
86	c IF (S0(i,j,l,ntra) .lt. 0. ) THEN
87	c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
88	c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
89	c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
90	c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
91	c PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ'
92	c STOP
93	c ENDIF
94	399 CONTINUE
95
96	C-----------------------------------------------------------------
97	C *** Test : diag de la qqtite totale de traceur
98	C dans l'atmosphere avant l'advection en z
99	sqi = 0.
100	sqf = 0.
101
102	DO l = 1,llm
103	DO j = 1,jjp1
104	DO i = 1,iim
105	cIM 240305 sqi = sqi + S0(i,j,l,9)
106	sqi = sqi + S0(i,j,l,ntra)
107	ENDDO
108	ENDDO
109	ENDDO
110	PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------'
111	PRINT*,'sqi=',sqi
112
113	C-----------------------------------------------------------------
114	C Interface : adaptation nouveau modele
115	C -------------------------------------
116	C
117	C Conversion du flux de masse en kg.s-1
118
119	DO l = 1,llm
120	DO j = 1,jjp1
121	DO i = 1,iip1
122	c wgri (i,j,llm+1-l) = w (i,j,l) / g
123	wgri (i,j,llm+1-l) = w (i,j,l)
124	c wgri (i,j,0) = 0. ! a detruire ult.
125	c wgri (i,j,l) = 0.1 ! w (i,j,l)
126	c wgri (i,j,llm) = 0. ! a detruire ult.
127	END DO
128	END DO
129	END DO
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 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 JV=1,NTRA
149	DO L=1,NIV
150	DO 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	END DO
154	END DO
155	END DO
156	C
157	101 CONTINUE
158	C
159	C boucle sur les niveaux intercouches de 1 a NIV-1
160	C (flux nul au sommet L=0 et a la base L=NIV)
161	C
162	C calculate flux and moments between adjacent boxes
163	C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
164	C 1- create temporary moments/masses for partial boxes in transit
165	C 2- reajusts moments remaining in the box
166	C
167	DO L=1,NIV-1
168	LP=L+1
169	C
170	DO I=1,LON
171	C
172	IF(WGRI(I,K,L)<0.) THEN
173	FM(I,L)=-WGRI(I,K,L)*DTZ
174	ALF(I)=FM(I,L)/SM(I,K,LP)
175	SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
176	ELSE
177	FM(I,L)=WGRI(I,K,L)*DTZ
178	ALF(I)=FM(I,L)/SM(I,K,L)
179	SM(I,K,L)=SM(I,K,L)-FM(I,L)
180	ENDIF
181	C
182	ALFQ (I)=ALF(I)*ALF(I)
183	ALF1 (I)=1.-ALF(I)
184	ALF1Q(I)=ALF1(I)*ALF1(I)
185	C
186	END DO
187	C
188	DO JV=1,NTRA
189	DO I=1,LON
190	C
191	IF(WGRI(I,K,L)<0.) THEN
192	C
193	F0(I,L,JV)=ALF (I)( S0(I,K,LP,JV)-ALF1(I)sz(I,K,LP,JV) )
194	FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV)
195	FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV)
196	FY(I,L,JV)=ALF (I)*sy(I,K,LP,JV)
197	C
198	S0(I,K,LP,JV)=S0(I,K,LP,JV)-F0(I,L,JV)
199	sz(I,K,LP,JV)=ALF1Q(I)*sz(I,K,LP,JV)
200	sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV)
201	sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV)
202	C
203	ELSE
204	C
205	F0(I,L,JV)=ALF (I)(S0(I,K,L,JV)+ALF1(I)sz(I,K,L,JV) )
206	FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV)
207	FX(I,L,JV)=ALF (I)*sx(I,K,L,JV)
208	FY(I,L,JV)=ALF (I)*sy(I,K,L,JV)
209	C
210	S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,L,JV)
211	sz(I,K,L,JV)=ALF1Q(I)*sz(I,K,L,JV)
212	sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV)
213	sy(I,K,L,JV)=sy(I,K,L,JV)-FY(I,L,JV)
214	C
215	ENDIF
216	C
217	END DO
218	END DO
219	C
220	END DO
221	C
222	C puts the temporary moments Fi into appropriate neighboring boxes
223	C
224	DO L=1,NIV-1
225	LP=L+1
226	C
227	DO I=1,LON
228	C
229	IF(WGRI(I,K,L)<0.) THEN
230	SM(I,K,L)=SM(I,K,L)+FM(I,L)
231	ALF(I)=FM(I,L)/SM(I,K,L)
232	ELSE
233	SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
234	ALF(I)=FM(I,L)/SM(I,K,LP)
235	ENDIF
236	C
237	ALF1(I)=1.-ALF(I)
238	ALFQ(I)=ALF(I)*ALF(I)
239	ALF1Q(I)=ALF1(I)*ALF1(I)
240	C
241	END DO
242	C
243	DO JV=1,NTRA
244	DO I=1,LON
245	C
246	IF(WGRI(I,K,L)<0.) THEN
247	C
248	TEMPTM=-ALF(I)S0(I,K,L,JV)+ALF1(I)F0(I,L,JV)
249	S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
250	sz(I,K,L,JV)=ALF(I)FZ(I,L,JV)+ALF1(I)sz(I,K,L,JV)+3.*TEMPTM
251	sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV)
252	sy(I,K,L,JV)=sy(I,K,L,JV)+FY(I,L,JV)
253	C
254	ELSE
255	C
256	TEMPTM=ALF(I)S0(I,K,LP,JV)-ALF1(I)F0(I,L,JV)
257	S0(I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
258	sz(I,K,LP,JV)=ALF(I)FZ(I,L,JV)+ALF1(I)sz(I,K,LP,JV)
259	+ +3.*TEMPTM
260	sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV)
261	sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(I,L,JV)
262	C
263	ENDIF
264	C
265	END DO
266	END DO
267	C
268	END DO
269	C
270	C fin de la boucle principale sur les latitudes
271	C
272	END DO
273	C
274	C-------------------------------------------------------------
275	C
276	C ----------- AA Test en fin de ADVX ------ Controle des S*
277
278	c DO 9999 l = 1, llm
279	c DO 9999 j = 1, jjp1
280	c DO 9999 i = 1, iip1
281	c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
282	c PRINT*, '-------------------'
283	c PRINT*, 'En fin de ADVZ'
284	c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
285	c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
286	c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
287	c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
288	c WRITE (,) 'On arrete !! - pbl en fin de ADVZ1'
289	c STOP
290	c ENDIF
291	9999 CONTINUE
292
293	C *** ------------------- bouclage cyclique en X ------------
294
295	c DO l = 1,llm
296	c DO j = 1,jjp1
297	c SM(iip1,j,l) = SM(1,j,l)
298	c S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
299	C sx(iip1,j,l,ntra) = sx(1,j,l,ntra)
300	c sy(iip1,j,l,ntra) = sy(1,j,l,ntra)
301	c sz(iip1,j,l,ntra) = sz(1,j,l,ntra)
302	c ENDDO
303	c ENDDO
304
305	C-------------------------------------------------------------
306	C *** Test : diag de la qqtite totale de traceur
307	C dans l'atmosphere avant l'advection en z
308	DO l = 1,llm
309	DO j = 1,jjp1
310	DO i = 1,iim
311	cIM 240305 sqf = sqf + S0(i,j,l,9)
312	sqf = sqf + S0(i,j,l,ntra)
313	ENDDO
314	ENDDO
315	ENDDO
316	PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
317	PRINT*,'sqf=', sqf
318
319	C-------------------------------------------------------------
320	RETURN
321	END
322	C_______________________________________________________________
323	C_______________________________________________________________

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

Download in other formats:

Original Format