Context Navigation

phystokenc.F @ 1006

Last change on this file since 1006 was 230, checked in by lmdzadmin, 23 years ago
Merge de la physique avec la branche principale LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 11.1 KB

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

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

Download in other formats:

Original Format