Context Navigation

phystokenc.F @ 188

Last change on this file since 188 was 188, checked in by lmdzadmin, 23 years ago
Modif Idelkadi LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 10.3 KB

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

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

Download in other formats:

Original Format