Context Navigation

phystokenc.F @ 4999

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

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

Download in other formats:

Original Format