Context Navigation

phystokenc.F @ 1436

Last change on this file since 1436 was 634, checked in by Laurent Fairhead, 20 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

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
	14	USE histcom
[634]	15	USE dimphy
	16	USE iophy
[524]	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"
[634]	26	cym#include "dimphy.h"
[524]	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
[541]	44	integer physid, itap
	45	save physid
	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
[634]	57	real pt(klon,klev)
	58	REAL,allocatable,save :: t(:,:)
[524]	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)
[541]	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)
[634]	75
	76	REAL,allocatable,save :: entr_therm(:,:)
	77	REAL,allocatable,save :: fm_therm(:,:)
[524]	78	c
	79	c Lessivage:
	80	c ----------
	81	c
[541]	82	REAL frac_impa(klon,klev)
	83	REAL frac_nucl(klon,klev)
[524]	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
[634]	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
[524]	100
[634]	101	REAL,allocatable,save :: pyu1(:)
	102	REAL,allocatable,save :: pyv1(:)
	103	REAL,allocatable,save :: pftsol(:,:)
	104	REAL,allocatable,save :: ppsrf(:,:)
	105
[524]	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
[541]	113	logical ok_sync
	114
[634]	115	save dtcum
[524]	116	save iadvtr,irec
	117
	118	data iadvtr,irec/0,1/
[634]	119	logical,save :: first=.true.
[524]	120	c
	121	c Couche limite:
	122	c======================================================================
	123
[541]	124	ok_sync = .true.
	125	print*,'Dans phystokenc.F'
[524]	126	print*,'iadvtr= ',iadvtr
	127	print*,'istphy= ',istphy
	128	print*,'istdyn= ',istdyn
	129
[634]	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
[524]	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
[541]	160	ndex2d = 0
	161	ndex3d = 0
	162	i=itap
[634]	163	cym CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
	164	CALL histwrite_phy(physid,"phis",i,pphis)
[541]	165	c
	166	i=itap
[634]	167	cym CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
	168	CALL histwrite_phy(physid,"aire",i,paire)
[541]	169
[524]	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.
[541]	184	t(i,k)=0.
	185	fm_therm(i,k)=0.
	186	entr_therm(i,k)=0.
[524]	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
[541]	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
[524]	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
[541]	229
	230	IF(mod(iadvtr,istphy).eq.0) THEN
[524]	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
[541]	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
[524]	246	enddo
	247	enddo
	248	do i=1,klon
	249	pyv1(i)=pyv1(i)/dtcum
	250	pyu1(i)=pyu1(i)/dtcum
	251	end do
[541]	252	do k=1,nbsrf
[524]	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
[541]	260	ppsrf(i,k)=ppsrf(i,k)/dtcum
[524]	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
[541]	267	enddo
[524]	268	c
	269	c ecriture des champs
	270	c
	271	irec=irec+1
	272
	273	ccccc
[634]	274	cym CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d)
	275	CALL histwrite_phy(physid,"t",itap,t)
[524]	276
[634]	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)
[541]	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
[634]	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)
[541]	301	c
[634]	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)
[524]	304	cccc
[634]	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)
[524]	307
[634]	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)
[541]	310
[634]	311	cym CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)
	312	CALL histwrite_phy(physid,"pyu1",itap,pyu1)
[541]	313
[634]	314	cym CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)
	315	CALL histwrite_phy(physid,"pyv1",itap,pyv1)
[541]	316
[634]	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)
[524]	325
[634]	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)
[524]	334
[541]	335	if (ok_sync) call histsync(physid)
	336	c if (ok_sync) call histsync
	337
[524]	338	c
[541]	339	cAA Test sur la valeur des coefficients de lessivage
[524]	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
[541]	361	ENDIF
[524]	362
[541]	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
[524]	390
[541]	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
[524]	422	RETURN
	423	END

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

Download in other formats:

Original Format