Context Navigation

advz.F @ 802

Last change on this file since 802 was 644, checked in by Laurent Fairhead, 20 years ago
Synchronisation avec tous les diagnostiques de Ionela IM Inclusion du slab ocean IM LF
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