Context Navigation

phystokenc.F @ 5415

Last change on this file since 5415 was 524, checked in by lmdzadmin, 21 years ago
Initial revision
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 11.1 KB

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

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

Download in other formats:

Original Format