Context Navigation

phystokenc.F @ 5373

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

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

Download in other formats:

Original Format