Context Navigation

phystokenc.F @ 758

Last change on this file since 758 was 541, checked in by lmdzadmin, 20 years ago

Convergence avec la version d'Olivia Coindreau incluant:

le offline
les thermiques
mellor & yamada dans la couche limite

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

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

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

Download in other formats:

Original Format