Context Navigation

phystokenc.F @ 177

Last change on this file since 177 was 177, checked in by lmdzadmin, 23 years ago

Lots of stuff, plus particulierement:

appel a ORCHIDEE en etat de marche (pb de grille subsiste)
modifs de Pascale sur soil dans le cas ou ok_veget=false -

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 10.2 KB

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

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

Download in other formats:

Original Format