Context Navigation

phystokenc.F @ 1373

Last change on this file since 1373 was 1299, checked in by Laurent Fairhead, 15 years ago

Nettoyage general pour se rapprocher des normes et éviter des erreurs a la
compilation:

tous les FLOAT() sont remplacés par des REAL()
tous les STOP dans phylmd sont remplacés par des appels à abort_gcm
le common control défini dans le fichier control.h est remplacé par le module control_mod pour éviter des messages sur l'alignement des variables dans les déclarations
des $Header$ remplacés par des $Id$ pour svn

Quelques remplacements à faire ont pu m'échapper

General cleanup of the code to try and adhere to norms and to prevent some
compilation errors:

all FLOAT() instructions have been replaced by REAL() instructions
all STOP instructions in phylmd have been replaced by calls to abort_gcm
the common block control defined in the control.h file has been replaced by the control_mod to prevent compilation warnings on the alignement of declared variables
$Header$ replaced by $Id$ for svn

Some changes which should have been made might have escaped me

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 13.3 KB

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

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

Download in other formats:

Original Format