Context Navigation

phystokenc.F @ 152

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

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

Download in other formats:

Original Format