Context Navigation

phystokenc.F @ 5306

Last change on this file since 5306 was 207, checked in by lmdz, 24 years ago
petit detail LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 11.1 KB

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

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

Download in other formats:

Original Format