Context Navigation

phystokenc.F @ 1955

Last change on this file since 1955 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

Rev	Line
[524]	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,
[541]	9	I pfm_therm,pentr_therm,
[524]	10	I pcoefh,yu1,yv1,ftsol,pctsrf,
[541]	11	I frac_impa,frac_nucl,
[524]	12	I pphis,paire,dtime,itap)
	13	USE ioipsl
[704]	14	USE dimphy
	15	USE iophy
[524]	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"
[704]	25	cym#include "dimphy.h"
[524]	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
[541]	43	integer physid, itap
	44	save physid
[704]	45	c$OMP THREADPRIVATE(physid)
[541]	46	integer ndex2d(iim(jjm+1)),ndex3d(iim(jjm+1)*klev)
[524]	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
[704]	57	real pt(klon,klev)
	58	REAL,allocatable,save :: t(:,:)
	59	c$OMP THREADPRIVATE(t)
[524]	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)
[541]	70
	71	c Les Thermiques : (Abderr 25 11 02)
	72	c ---------------
	73	REAL pfm_therm(klon,klev+1)
[704]	74	real fm_therm1(klon,klev)
[541]	75	REAL pentr_therm(klon,klev)
[704]	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)
[524]	81	c
	82	c Lessivage:
	83	c ----------
	84	c
[541]	85	REAL frac_impa(klon,klev)
	86	REAL frac_nucl(klon,klev)
[524]	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
[704]	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
[524]	103
[704]	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)
[524]	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
[541]	117	logical ok_sync
	118
[704]	119	save dtcum
[524]	120	save iadvtr,irec
[704]	121	c$OMP THREADPRIVATE(dtcum,iadvtr,irec)
[524]	122	data iadvtr,irec/0,1/
[704]	123	logical,save :: first=.true.
	124	c$OMP THREADPRIVATE(first)
[524]	125	c
	126	c Couche limite:
	127	c======================================================================
	128
[541]	129	ok_sync = .true.
	130	print*,'Dans phystokenc.F'
[524]	131	print*,'iadvtr= ',iadvtr
	132	print*,'istphy= ',istphy
	133	print*,'istdyn= ',istdyn
	134
[704]	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
[524]	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
[541]	165	ndex2d = 0
	166	ndex3d = 0
	167	i=itap
[704]	168	cym CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
	169	CALL histwrite_phy(physid,"phis",i,pphis)
[541]	170	c
	171	i=itap
[704]	172	cym CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
	173	CALL histwrite_phy(physid,"aire",i,paire)
[541]	174
[524]	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.
[541]	189	t(i,k)=0.
	190	fm_therm(i,k)=0.
	191	entr_therm(i,k)=0.
[524]	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
[541]	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
[524]	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
[541]	234
	235	IF(mod(iadvtr,istphy).eq.0) THEN
[524]	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
[541]	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
[524]	251	enddo
	252	enddo
	253	do i=1,klon
	254	pyv1(i)=pyv1(i)/dtcum
	255	pyu1(i)=pyu1(i)/dtcum
	256	end do
[541]	257	do k=1,nbsrf
[524]	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
[541]	265	ppsrf(i,k)=ppsrf(i,k)/dtcum
[524]	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
[541]	272	enddo
[524]	273	c
	274	c ecriture des champs
	275	c
	276	irec=irec+1
	277
	278	ccccc
[704]	279	cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d)
	280	CALL histwrite_phy(physid,"t",itap,t)
[524]	281
[704]	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)
[541]	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
[704]	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)
[541]	306	c
[704]	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)
[524]	309	cccc
[704]	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)
[524]	312
[704]	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)
[541]	315
[704]	316	cym CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)
	317	CALL histwrite_phy(physid,"pyu1",itap,pyu1)
[541]	318
[704]	319	cym CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)
	320	CALL histwrite_phy(physid,"pyv1",itap,pyv1)
[541]	321
[704]	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)
[524]	330
[704]	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)
[524]	339
[704]	340	c$OMP MASTER
[541]	341	if (ok_sync) call histsync(physid)
[704]	342	c$OMP END MASTER
[541]	343	c if (ok_sync) call histsync
	344
[524]	345	c
[541]	346	cAA Test sur la valeur des coefficients de lessivage
[524]	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
[541]	368	ENDIF
[524]	369
[541]	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
[524]	397
[541]	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
[524]	429	RETURN
	430	END

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

Download in other formats:

Original Format