Context Navigation

phystokenc.F @ 478

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

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

Download in other formats:

Original Format