Context Navigation

phystokenc.F @ 349

Last change on this file since 349 was 207, checked in by lmdz, 25 years ago
petit detail LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 11.1 KB

Line
1	c
2	c $Header$
3	c
4	SUBROUTINE phystokenc (
5	I nlon,nlev,pdtphys,rlon,rlat,
6	I pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
7	I pcoefh,yu1,yv1,ftsol,pctsrf,
8	I pfrac_impa,pfrac_nucl,
9	I pphis,paire,dtime,itap)
10	USE ioipsl
11
12	IMPLICIT none
13
14	c======================================================================
15	c Auteur(s) FH
16	c Objet: Moniteur general des tendances traceurs
17	c
18
19	c======================================================================
20	#include "dimensions.h"
21	#include "dimphy.h"
22	#include "tracstoke.h"
23	#include "indicesol.h"
24	#include "control.h"
25	c======================================================================
26
27	c Arguments:
28	c
29	c EN ENTREE:
30	c ==========
31	c
32	c divers:
33	c -------
34	c
35	integer nlon ! nombre de points horizontaux
36	integer nlev ! nombre de couches verticales
37	real pdtphys ! pas d'integration pour la physique (seconde)
38	c
39	integer physid, itap,ndex(1)
40
41	c convection:
42	c -----------
43	c
44	REAL pmfu(klon,klev) ! flux de masse dans le panache montant
45	REAL pmfd(klon,klev) ! flux de masse dans le panache descendant
46	REAL pen_u(klon,klev) ! flux entraine dans le panache montant
47	REAL pde_u(klon,klev) ! flux detraine dans le panache montant
48	REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
49	REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
50	REAL pt(klon,klev)
51	c
52	REAL rlon(klon), rlat(klon), dtime
53	REAL zx_tmp_3d(iim,jjm+1,klev),zx_tmp_2d(iim,jjm+1)
54
55	c Couche limite:
56	c --------------
57	c
58	REAL pcoefh(klon,klev) ! coeff melange CL
59	REAL yv1(klon)
60	REAL yu1(klon),pphis(klon),paire(klon)
61	c
62	c Lessivage:
63	c ----------
64	c
65	REAL pfrac_impa(klon,klev)
66	REAL pfrac_nucl(klon,klev)
67	c
68	c Arguments necessaires pour les sources et puits de traceur
69	C
70	real ftsol(klon,nbsrf) ! Temperature du sol (surf)(Kelvin)
71	real pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
72	c======================================================================
73	c
74	INTEGER i, k
75	c
76	REAL mfu(klon,klev) ! flux de masse dans le panache montant
77	REAL mfd(klon,klev) ! flux de masse dans le panache descendant
78	REAL en_u(klon,klev) ! flux entraine dans le panache montant
79	REAL de_u(klon,klev) ! flux detraine dans le panache montant
80	REAL en_d(klon,klev) ! flux entraine dans le panache descendant
81	REAL de_d(klon,klev) ! flux detraine dans le panache descendant
82	REAL coefh(klon,klev) ! flux detraine dans le panache descendant
83	REAL t(klon,klev)
84	REAL frac_impa(klon,klev)
85	REAL frac_nucl(klon,klev)
86	REAL rain(klon)
87
88	REAL pyu1(klon),pyv1(klon)
89	REAL pftsol(klon,nbsrf),ppsrf(klon,nbsrf)
90	real pftsol1(klon),pftsol2(klon),pftsol3(klon),pftsol4(klon)
91	real ppsrf1(klon),ppsrf2(klon),ppsrf3(klon),ppsrf4(klon)
92
93	REAL dtcum
94
95	integer iadvtr,irec
96	real zmin,zmax
97
98	save t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,dtcum
99	save iadvtr,irec
100	save frac_impa,frac_nucl,rain
101	save pyu1,pyv1,pftsol,ppsrf
102
103	data iadvtr,irec/0,1/
104	c
105	c Couche limite:
106	c======================================================================
107
108	print*,'iadvtr= ',iadvtr
109	print*,'istphy= ',istphy
110	print*,'istdyn= ',istdyn
111
112	IF (iadvtr.eq.0) THEN
113
114	CALL initphysto('phystoke',
115	. rlon,rlat,dtime, dtimeistphy,dtimeistphy,nqmx,physid)
116
117	write(,) 'apres initphysto ds phystokenc'
118
119	ndex(1) = 0
120	i=itap
121	CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
122	CALL histwrite(physid,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex)
123	c
124	i=itap
125	CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
126	CALL histwrite(physid,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
127
128	ENDIF
129	c
130	iadvtr=iadvtr+1
131	c
132	c
133	c reinitialisation des champs cumules
134	if (mod(iadvtr,istphy).eq.1.or.istphy.eq.1) then
135	print*,'reinitialisation des champs cumules
136	s a iadvtr=',iadvtr
137	do k=1,klev
138	do i=1,klon
139	frac_impa(i,k)=1.
140	frac_nucl(i,k)=1.
141	mfu(i,k)=0.
142	mfd(i,k)=0.
143	en_u(i,k)=0.
144	de_u(i,k)=0.
145	en_d(i,k)=0.
146	de_d(i,k)=0.
147	coefh(i,k)=0.
148	t(i,k)=0.
149	enddo
150	enddo
151	do i=1,klon
152	rain(i)=0.
153	pyv1(i)=0.
154	pyu1(i)=0.
155	end do
156	do k=1,nbsrf
157	do i=1,klon
158	pftsol(i,k)=0.
159	ppsrf(i,k)=0.
160	enddo
161	enddo
162
163	dtcum=0.
164	endif
165
166	do k=1,klev
167	do i=1,klon
168	frac_impa(i,k)=frac_impa(i,k)*pfrac_impa(i,k)
169	frac_nucl(i,k)=frac_nucl(i,k)*pfrac_nucl(i,k)
170	mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
171	mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
172	en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
173	de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
174	en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
175	de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
176	coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
177	t(i,k)=t(i,k)+pt(i,k)*pdtphys
178	enddo
179	enddo
180	do i=1,klon
181	pyv1(i)=pyv1(i)+yv1(i)*pdtphys
182	pyu1(i)=pyu1(i)+yu1(i)*pdtphys
183	end do
184	do k=1,nbsrf
185	do i=1,klon
186	pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
187	ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
188	enddo
189	enddo
190
191	dtcum=dtcum+pdtphys
192	c
193	IF(mod(iadvtr,istphy).eq.0) THEN
194	c
195	c normalisation par le temps cumule
196	do k=1,klev
197	do i=1,klon
198	c frac_impa=frac_impa : c'est la fraction cumulee qu'on stoke
199	c frac_nucl=frac_nucl : c'est la fraction cumulee qu'on stoke
200	mfu(i,k)=mfu(i,k)/dtcum
201	mfd(i,k)=mfd(i,k)/dtcum
202	en_u(i,k)=en_u(i,k)/dtcum
203	de_u(i,k)=de_u(i,k)/dtcum
204	en_d(i,k)=en_d(i,k)/dtcum
205	de_d(i,k)=de_d(i,k)/dtcum
206	coefh(i,k)=coefh(i,k)/dtcum
207	t(i,k)=t(i,k)/dtcum
208	enddo
209	enddo
210	do i=1,klon
211	rain(i)=rain(i)/dtcum
212	pyv1(i)=pyv1(i)/dtcum
213	pyu1(i)=pyu1(i)/dtcum
214	end do
215	c modif abderr 23 11 00 do k=1,nbsrf
216	do i=1,klon
217	do k=1,nbsrf
218	pftsol(i,k)=pftsol(i,k)/dtcum
219	ppsrf(i,k)=ppsrf(i,k)/dtcum
220	enddo
221	pftsol1(i) = pftsol(i,1)
222	pftsol2(i) = pftsol(i,2)
223	pftsol3(i) = pftsol(i,3)
224	pftsol4(i) = pftsol(i,4)
225
226	c ppsrf(i,k)=ppsrf(i,k)/dtcum
227	ppsrf1(i) = ppsrf(i,1)
228	ppsrf2(i) = ppsrf(i,2)
229	ppsrf3(i) = ppsrf(i,3)
230	ppsrf4(i) = ppsrf(i,4)
231
232	enddo
233	c enddo
234	c
235	c ecriture des champs
236	c
237	irec=irec+1
238
239	ccccc
240	print*,'AVANT ECRITURE'
241	CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d)
242	CALL histwrite(physid,"t",itap,zx_tmp_3d,
243	. iim(jjm+1)klev,ndex)
244	print*,'APRES ECRITURE'
245
246	CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d)
247	CALL histwrite(physid,"mfu",itap,zx_tmp_3d,
248	. iim(jjm+1)klev,ndex)
249	CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d)
250	CALL histwrite(physid,"mfd",itap,zx_tmp_3d,
251	. iim(jjm+1)klev,ndex)
252	CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d)
253	CALL histwrite(physid,"en_u",itap,zx_tmp_3d,
254	. iim(jjm+1)klev,ndex)
255	CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d)
256	CALL histwrite(physid,"de_u",itap,zx_tmp_3d,
257	. iim(jjm+1)klev,ndex)
258	CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d)
259	CALL histwrite(physid,"en_d",itap,zx_tmp_3d,
260	. iim(jjm+1)klev,ndex)
261	CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d)
262	CALL histwrite(physid,"de_d",itap,zx_tmp_3d,
263	. iim(jjm+1)klev,ndex)
264	CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d)
265	CALL histwrite(physid,"coefh",itap,zx_tmp_3d,
266	. iim(jjm+1)klev,ndex)
267	cccc
268	CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d)
269	CALL histwrite(physid,"frac_impa",itap,zx_tmp_3d,
270	. iim(jjm+1)klev,ndex)
271
272	CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d)
273	CALL histwrite(physid,"frac_nucl",itap,zx_tmp_3d,
274	. iim(jjm+1)klev,ndex)
275
276	CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)
277	CALL histwrite(physid,"pyu1",itap,zx_tmp_2d,iim*(jjm+1),ndex)
278
279	CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)
280	CALL histwrite(physid,"pyv1",itap,zx_tmp_2d,iim*(jjm+1),ndex)
281
282	CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d)
283	CALL histwrite(physid,"ftsol1",itap,zx_tmp_2d,
284	. iim*(jjm+1),ndex)
285	CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d)
286	CALL histwrite(physid,"ftsol2",itap,zx_tmp_2d,
287	. iim*(jjm+1),ndex)
288	CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d)
289	CALL histwrite(physid,"ftsol3",itap,zx_tmp_2d,
290	. iim*(jjm+1),ndex)
291
292	c
293	CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d)
294	CALL histwrite(physid,"ftsol4",itap,zx_tmp_2d,
295	. iim*(jjm+1),ndex)
296
297	CALL gr_fi_ecrit(1,klon,iim,jjm+1, rain, zx_tmp_2d)
298	CALL histwrite(physid,"rain",itap,zx_tmp_2d,
299	. iim*(jjm+1),ndex)
300
301	CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d)
302	CALL histwrite(physid,"psrf1",itap,zx_tmp_2d,
303	. iim*(jjm+1),ndex)
304	CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d)
305	CALL histwrite(physid,"psrf2",itap,zx_tmp_2d,
306	. iim*(jjm+1),ndex)
307	CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d)
308	CALL histwrite(physid,"psrf3",itap,zx_tmp_2d,
309	. iim*(jjm+1),ndex)
310	CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d)
311	CALL histwrite(physid,"psrf4",itap,zx_tmp_2d,
312	. iim*(jjm+1),ndex)
313
314	c
315	cAA Test sur la valeur des coefficients de lessivage
316	c
317	zmin=1e33
318	zmax=-1e33
319	do k=1,klev
320	do i=1,klon
321	zmax=max(zmax,frac_nucl(i,k))
322	zmin=min(zmin,frac_nucl(i,k))
323	enddo
324	enddo
325	Print*,'------ coefs de lessivage (min et max) --------'
326	Print*,'facteur de nucleation ',zmin,zmax
327	zmin=1e33
328	zmax=-1e33
329	do k=1,klev
330	do i=1,klon
331	zmax=max(zmax,frac_impa(i,k))
332	zmin=min(zmin,frac_impa(i,k))
333	enddo
334	enddo
335	Print*,'facteur d impaction ',zmin,zmax
336
337	ENDIF
338
339
340	RETURN
341	END

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

Download in other formats:

Original Format