Context Navigation

cvltr_scav.F90 @ 5133

Last change on this file since 5133 was 5117, checked in by abarral, 5 months ago
rename modules properly lmdz_* move some unused files to obsolete/ (lint) uppercase fortran keywords
File size: 28.5 KB

Rev	Line
[5099]	1
[2147]	2	! $Id $
[5099]	3
[2147]	4	SUBROUTINE cvltr_scav(pdtime, da, phi,phi2,d1a,dam, mpIN,epIN, &
	5	sigd,sij,wght_cvfd,clw,elij,epmlmMm,eplaMm, &
	6	pmflxrIN,pmflxsIN,ev,te,wdtrainA,wdtrainM, &
	7	paprs,it,tr,upd,dnd,inb,icb, &
	8	ccntrAA_3d,ccntrENV_3d,coefcoli_3d, &
	9	dtrcv,trsptd,dtrSscav,dtrsat,dtrUscav,qDi,qPr, &
	10	qPa,qMel,qTrdi,dtrcvMA,Mint, &
	11	zmfd1a,zmfphi2,zmfdam)
[5099]	12
[2147]	13	USE IOIPSL
	14	USE dimphy
[5101]	15	USE infotrac_phy, ONLY: nbtr
[2147]	16	IMPLICIT NONE
	17	!=====================================================================
	18	! Objet : convection des traceurs / KE
	19	! Auteurs: M-A Filiberti and J-Y Grandpeix
	20	! modifiee par R Pilon : lessivage des traceurs / KE
	21	!=====================================================================
	22
	23	include "YOMCST.h"
	24	include "YOECUMF.h"
	25	include "conema3.h"
	26	include "chem.h"
	27
	28	! Entree
	29	REAL,INTENT(IN) :: pdtime
	30	REAL,DIMENSION(klon,klev),INTENT(IN) :: da
	31	REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
	32	! RomP
	33	REAL,DIMENSION(klon,klev),INTENT(IN) :: d1a,dam ! matrices pour simplifier
	34	REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi2 ! l'ecriture des tendances
[5099]	35
[2147]	36	REAL,DIMENSION(klon,klev),INTENT(IN) :: mpIN
	37	REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression aux 1/2 couches (bas en haut)
	38	INTEGER,INTENT(IN) :: it ! numero du traceur
	39	REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr ! q de traceur (bas en haut)
	40	REAL,DIMENSION(klon,klev),INTENT(IN) :: upd ! saturated updraft mass flux
	41	REAL,DIMENSION(klon,klev),INTENT(IN) :: dnd ! saturated downdraft mass flux
[5099]	42
[2147]	43	REAL,DIMENSION(klon,klev),INTENT(IN) :: wdtrainA ! masses precipitantes de l'asc adiab
	44	REAL,DIMENSION(klon,klev),INTENT(IN) :: wdtrainM ! masses precipitantes des melanges
	45	!JE REAL,DIMENSION(klon,klev),INTENT(IN) :: pmflxrIN ! vprecip: eau
	46	REAL,DIMENSION(klon,klev+1),INTENT(IN) :: pmflxrIN ! vprecip: eau
	47	!JE REAL,DIMENSION(klon,klev),INTENT(IN) :: pmflxsIN ! vprecip: neige
	48	REAL,DIMENSION(klon,klev+1),INTENT(IN) :: pmflxsIN ! vprecip: neige
	49	REAL,DIMENSION(klon,klev),INTENT(IN) :: ev ! evaporation cv30_routine
	50	REAL,DIMENSION(klon,klev),INTENT(IN) :: epIN
	51	REAL,DIMENSION(klon,klev),INTENT(IN) :: te
	52	REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij ! fraction dair de lenv
	53	REAL,DIMENSION(klon,klev),INTENT(IN) :: wght_cvfd ! weights of the layers feeding convection
	54	REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij ! contenu en eau condensée spécifique/conc deau condensée massique
	55	REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm ! eau condensee precipitee dans mel masse dair sat
	56	REAL,DIMENSION(klon,klev),INTENT(IN) :: eplaMm ! eau condensee precipitee dans aa masse dair sat
	57
	58	REAL,DIMENSION(klon,klev),INTENT(IN) :: clw ! contenu en eau condensée dans lasc adiab
	59	REAL,DIMENSION(klon),INTENT(IN) :: sigd
	60	INTEGER,DIMENSION(klon),INTENT(IN) :: icb,inb
[5099]	61
[2147]	62	REAL,DIMENSION(klon,klev),INTENT(IN) :: ccntrAA_3d
	63	REAL,DIMENSION(klon,klev),INTENT(IN) :: ccntrENV_3d
	64	REAL,DIMENSION(klon,klev),INTENT(IN) :: coefcoli_3d
[5099]	65
[2147]	66	! Sortie
	67	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: dtrcv ! tendance totale (bas en haut)
	68	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: dtrcvMA ! M-A Filiberti
	69	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: trsptd ! tendance du transport
	70	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: dtrSscav ! tendance du lessivage courant sat
	71	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: dtrsat ! tendance trsp+sat scav
	72	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: dtrUscav ! tendance du lessivage courant unsat
[5099]	73
[2147]	74	! Variables locales
	75	INTEGER :: i,j,k
	76	REAL,DIMENSION(klon,klev) :: dxpres ! difference de pression entre niveau (j+1) et (j)
	77	REAL :: pdtimeRG ! pas de temps * gravite
	78	REAL,DIMENSION(klon,nbtr) :: qfeed ! tracer concentration feeding convection
	79	! variables pour les courants satures
	80	REAL,DIMENSION(klon,klev,klev) :: zmd
	81	REAL,DIMENSION(klon,klev,klev) :: za
	82	REAL,DIMENSION(klon,klev,nbtr) :: zmfd,zmfa
	83	REAL,DIMENSION(klon,klev,nbtr) :: zmfp,zmfu
	84
	85	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: zmfd1a
	86	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: zmfdam
	87	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: zmfphi2
	88
	89	! RomP ! les variables sont nettoyees des valeurs aberrantes
	90	REAL,DIMENSION(klon,klev) :: Pa, Pm ! pluie AA et mélanges, var temporaire
	91	REAL,DIMENSION(klon,klev) :: pmflxs,pmflxr ! pmflxrIN,pmflxsIN sans valeur aberante
	92	REAL,DIMENSION(klon,klev) :: mp ! flux de masse
	93	REAL,DIMENSION(klon,klev) :: ep ! fraction d'eau convertie en precipitation
	94	REAL,DIMENSION(klon,klev) :: evap ! evaporation : variable temporaire
	95	REAL,DIMENSION(klon,klev) :: rho !environmental density
	96
	97	REAL,DIMENSION(klon,klev) :: kappa ! denominateur du au calcul de la matrice
	98	! pour obtenir qd et qp
	99	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: qTrdi ! traceurs descente air insature transport MA
	100	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: qDi ! traceurs descente insaturees
	101	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: qPr ! traceurs colonne precipitante
	102	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: qPa ! traceurs dans les precip issues lasc. adiab.
	103	REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: qMel ! traceurs dans les precip issues des melanges
	104	REAL,DIMENSION(klon,klev,nbtr) :: qMeltmp ! variable temporaire
	105	REAL,DIMENSION(klon,klev,nbtr) :: qpmMint
	106	REAL,DIMENSION(klon,klev),INTENT(OUT) :: Mint
	107	! tendances
	108	REAL :: tdcvMA ! terme de transport de traceur (schema Marie Angele)
	109	REAL :: trsptrac ! terme de transport de traceur par l'air
	110	REAL :: scavtrac ! terme de lessivage courant sature
	111	REAL :: uscavtrac ! terme de lessivage courant insature
	112	! impaction
	113	!!! Correction apres discussion Romain P. / Olivier B.
	114	!!! REAL,PARAMETER :: rdrop=2.5e-3 ! rayon des gouttes d'eau
	115	REAL,PARAMETER :: rdrop=1.e-3 ! rayon des gouttes d'eau
	116	!!!
	117	REAL,DIMENSION(klon,klev) :: imp ! coefficient d'impaction
[5099]	118
[2147]	119	LOGICAL,DIMENSION(klon,klev) :: NO_precip
	120	! var tmp tests
	121	REAL :: conserv
	122	real :: conservMA
	123
[2284]	124	!jyg<
	125	!! ! ======================================================
	126	!! ! calcul de l'impaction
	127	!! ! ======================================================
	128	!!
	129	!! ! impaction sur la surface de la colonne de la descente insaturee
	130	!! ! On prend la moyenne des precip entre le niveau i+1 et i
	131	!! ! I=3/4* (P(1+1)+P(i))/2 / (sigdrrho_l)
	132	!! ! 1000kg/m3= densite de l'eau
	133	!! ! 0.75e-3 = 3/4 /1000
	134	!! ! Par la suite, I est tout le temps multiplie par sig_d pour avoir l'impaction sur la surface de la maille
	135	!!!! ! on le neglige ici pour simplifier le code
	136	!!
	137	!! DO j=1,klev-1
	138	!! DO i=1,klon
	139	!! imp(i,j) = coefcoli_3d(i,j)0.75e-3/rdrop &
	140	!! 0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
	141	!! ENDDO
	142	!! ENDDO
	143	!>jyg
[5099]	144
[2147]	145	! initialisation pour flux de traceurs, td et autre
[5099]	146
[2147]	147	trsptrac = 0.
	148	scavtrac = 0.
	149	uscavtrac = 0.
	150	qfeed(:,it) = 0. !RL
	151	DO j=1,klev
	152	DO i=1,klon
	153	zmfd(i,j,it)=0.
	154	zmfa(i,j,it)=0.
	155	zmfu(i,j,it)=0.
	156	zmfp(i,j,it)=0.
	157	zmfphi2(i,j,it)=0.
	158	zmfd1a(i,j,it)=0.
	159	zmfdam(i,j,it)=0.
	160	qDi(i,j,it)=0.
	161	qPr(i,j,it)=0.
	162	qPa(i,j,it)=0.
	163	qMel(i,j,it)=0.
	164	qMeltmp(i,j,it)=0.
	165	qTrdi(i,j,it)=0.
	166	kappa(i,j)=0.
	167	trsptd(i,j,it)=0.
	168	dtrsat(i,j,it)=0.
	169	dtrSscav(i,j,it)=0.
	170	dtrUscav(i,j,it)=0.
	171	dtrcv(i,j,it)=0.
	172	dtrcvMA(i,j,it)=0.
	173	evap(i,j)=0.
	174	dxpres(i,j)=0.
	175	qpmMint(i,j,it)=0.
	176	Mint(i,j)=0.
	177	END DO
	178	END DO
	179
	180	! suppression des valeurs très faibles (~1e-320)
	181	! multiplication de levaporation pour lavoir par unite de temps
	182	! et par unite de surface de la maille
	183	! -> cv30_unsat : evap : masse evaporee/s/(m2 de la descente)
	184	DO j=1,klev
	185	DO i=1,klon
[5082]	186	IF(ev(i,j)<1.e-16) THEN
[2147]	187	evap(i,j)=0.
	188	ELSE
	189	evap(i,j)=ev(i,j)*sigd(i)
	190	ENDIF
	191	END DO
	192	END DO
	193
	194	DO j=1,klev
	195	DO i=1,klon
[5082]	196	IF(j<klev) THEN
	197	IF(epIN(i,j)<1.e-32) THEN
[2147]	198	ep(i,j)=0.
	199	ELSE
	200	ep(i,j)=epIN(i,j)
	201	ENDIF
	202	ELSE
	203	ep(i,j)=epmax
	204	ENDIF
[5082]	205	IF(mpIN(i,j)<1.e-32) THEN
[2147]	206	mp(i,j)=0.
	207	ELSE
	208	mp(i,j)=mpIN(i,j)
	209	ENDIF
[5082]	210	IF(pmflxsIN(i,j)<1.e-32) THEN
[2147]	211	pmflxs(i,j)=0.
	212	ELSE
	213	pmflxs(i,j)=pmflxsIN(i,j)
	214	ENDIF
[5082]	215	IF(pmflxrIN(i,j)<1.e-32) THEN
[2147]	216	pmflxr(i,j)=0.
	217	ELSE
	218	pmflxr(i,j)=pmflxrIN(i,j)
	219	ENDIF
[5082]	220	IF(wdtrainA(i,j)<1.e-32) THEN
[2147]	221	Pa(i,j)=0.
	222	ELSE
	223	Pa(i,j)=wdtrainA(i,j)
	224	ENDIF
[5082]	225	IF(wdtrainM(i,j)<1.e-32) THEN
[2147]	226	Pm(i,j)=0.
	227	ELSE
	228	Pm(i,j)=wdtrainM(i,j)
	229	ENDIF
	230	END DO
	231	END DO
	232
	233	!==========================================
	234	DO j = klev-1,1,-1
	235	DO i = 1,klon
[5082]	236	NO_precip(i,j) = (pmflxr(i,j+1)+pmflxs(i,j+1))<1.e-10&
	237	.AND.Pa(i,j)<1.e-10.AND.Pm(i,j)<1.e-10
[2147]	238	END DO
	239	END DO
	240
[2284]	241	!jyg<
	242	! ======================================================
	243	! calcul de l'impaction
	244	! ======================================================
	245
	246	! impaction sur la surface de la colonne de la descente insaturee
	247	! On prend la moyenne des precip entre le niveau i+1 et i
	248	! I=3/4* (P(1+1)+P(i))/2 / (sigdrrho_l)
	249	! 1000kg/m3= densite de l'eau
	250	! 0.75e-3 = 3/4 /1000
	251	! Par la suite, I est tout le temps multiplie par sig_d pour avoir l'impaction sur la surface de la maille
	252	! on le neglige ici pour simplifier le code
	253
	254	DO j=1,klev-1
	255	DO i=1,klon
	256	imp(i,j) = coefcoli_3d(i,j)0.75e-3/rdrop &
	257	0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
	258	ENDDO
	259	ENDDO
	260	!>jyg
[2147]	261	! =========================================
	262	! calcul des tendances liees au downdraft
	263	! =========================================
	264	!cdir collapse
	265	DO k=1,klev
	266	DO j=1,klev
	267	DO i=1,klon
	268	zmd(i,j,k)=0.
	269	za (i,j,k)=0.
	270	END DO
	271	END DO
	272	END DO
	273	! calcul de la matrice d echange
	274	! matrice de distribution de la masse entrainee en k
	275	! commmentaire RomP : mp > 0
	276	DO k=1,klev-1
	277	DO i=1,klon
	278	zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1)) ! ~ mk(k)
	279	END DO
	280	END DO
	281	DO k=2,klev
	282	DO j=k-1,1,-1
	283	DO i=1,klon
[5082]	284	IF(mp(i,j+1)>1.e-10) THEN
[2147]	285	zmd(i,j,k)=zmd(i,j+1,k)min(1.,mp(i,j)/mp(i,j+1)) !det ~ mk(j)=mk(j+1)mp(i,j)/mp(i,j+1)
	286	ENDIF
	287	END DO
	288	END DO
	289	END DO
	290	DO k=1,klev
	291	DO j=1,klev-1
	292	DO i=1,klon
	293	za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
	294	END DO
	295	END DO
	296	END DO
	297	!!!!! quantite de traceur dans la descente d'air insaturee : 4 juin 2012
	298	DO k=1,klev
	299	DO j=1,klev-1
	300	DO i=1,klon
[5082]	301	IF(mp(i,j+1)>1.e-10) THEN
[2147]	302	qTrdi(i,j+1,it)=qTrdi(i,j+1,it)+(zmd(i,j+1,k)/mp(i,j+1))*tr(i,k,it)
	303	ELSE
	304	qTrdi(i,j,it)=0.!tr(i,j,it)
	305	ENDIF
	306	ENDDO
	307	ENDDO
	308	ENDDO
	309	!!!!!
[5099]	310
[2147]	311	! rajout du terme lie a l ascendance induite
[5099]	312
[2147]	313	DO j=2,klev
	314	DO i=1,klon
	315	za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
	316	END DO
	317	END DO
[5099]	318
[2147]	319	! tendance courants insatures ! sans lessivage ancien schema
[5099]	320
[2147]	321	DO k=1,klev
	322	DO j=1,klev
	323	DO i=1,klon
	324	zmfd(i,j,it)=zmfd(i,j,it)+za(i,j,k)*(tr(i,k,it)-tr(i,j,it))
	325	END DO
	326	END DO
	327	END DO
[5099]	328
[2147]	329	! =========================================
	330	! calcul des tendances liees aux courants satures j <-> z ; k <-> z'
	331	! =========================================
	332	!RL
	333	! Feeding concentrations
	334	DO j=1,klev
	335	DO i=1,klon
	336	qfeed(i,it)=qfeed(i,it)+wght_cvfd(i,j)*tr(i,j,it)
	337	END DO
	338	END DO
	339	!RL
[5099]	340
[2147]	341	DO j=1,klev
	342	DO i=1,klon
	343	!RL
	344	!! zmfa(i,j,it)=da(i,j)*(tr(i,1,it)-tr(i,j,it)) ! da
	345	zmfa(i,j,it)=da(i,j)*(qfeed(i,it)-tr(i,j,it)) ! da
	346	!RL
	347	END DO
	348	END DO
[5099]	349
[2147]	350	DO k=1,klev
	351	DO j=1,klev
	352	DO i=1,klon
	353	zmfp(i,j,it)=zmfp(i,j,it)+phi(i,j,k)*(tr(i,k,it)-tr(i,j,it)) ! phi
	354	END DO
	355	END DO
	356	END DO
	357	! RomP ajout des matrices liees au lessivage
	358	DO j=1,klev
	359	DO i=1,klon
	360	zmfd1a(i,j,it)=d1a(i,j)*tr(i,1,it) ! da1
	361	zmfdam(i,j,it)=dam(i,j)*tr(i,1,it) ! dam
	362	END DO
	363	END DO
	364	DO k=1,klev
	365	DO j=1,klev
	366	DO i=1,klon
	367	zmfphi2(i,j,it)=zmfphi2(i,j,it)+phi2(i,j,k)*tr(i,k,it) ! psi
	368	END DO
	369	END DO
	370	END DO
	371	DO j=1,klev-1
	372	DO i=1,klon
	373	zmfu(i,j,it)=max(0.,upd(i,j+1)+dnd(i,j+1))*(tr(i,j+1,it)-tr(i,j,it))
	374	END DO
	375	END DO
	376	DO j=2,klev
	377	DO i=1,klon
	378	zmfu(i,j,it)=zmfu(i,j,it)+min(0.,upd(i,j)+dnd(i,j))*(tr(i,j,it)-tr(i,j-1,it))
	379	END DO
	380	END DO
	381	! ===================================================
	382	! calcul des tendances liees aux courants insatures
	383	! ===================================================
	384	! pression
	385	DO k=1, klev
	386	DO i=1, klon
	387	dxpres(i,k)=paprs(i,k)-paprs(i,k+1)
	388	ENDDO
	389	ENDDO
	390	pdtimeRG=pdtime*RG
	391
	392	! q_pa et q_pm traceurs issues des courants satures se retrouvant dans les precipitations
	393	DO j=1,klev
	394	DO i=1,klon
[5082]	395	IF(j>=icb(i).AND.j<=inb(i)) THEN
	396	IF(clw(i,j)>1.e-16) THEN
[2147]	397	!JE qPa(i,j,it)=ccntrAA_coef*tr(i,1,it)/clw(i,j)
	398	qPa(i,j,it)=ccntrAA_3d(i,j)*tr(i,1,it)/clw(i,j)
	399	ELSE
	400	qPa(i,j,it)=0.
	401	ENDIF
	402	ENDIF
	403	END DO
	404	END DO
	405
	406	! calcul de q_pm en 2 parties :
	407	! 1) calcul de sa valeur pour un niveau z' donne
	408	! 2) integration sur la verticale sur z'
	409	DO j=1,klev
	410	DO k=1,j-1
	411	DO i=1,klon
[5082]	412	IF(k>=icb(i).AND.k<=inb(i).AND.&
	413	j<=inb(i)) THEN
	414	IF(elij(i,k,j)>1.e-16) THEN
[2147]	415	!JE qMeltmp(i,j,it)=((1-ep(i,k))ccntrAA_coeftr(i,1,it)&
	416	!JE *(1.-sij(i,k,j)) +ccntrENV_coef&
	417	!JE tr(i,k,it)sij(i,k,j)) / elij(i,k,j)
	418	qMeltmp(i,j,it)=((1-ep(i,k))ccntrAA_3d(i,k)tr(i,1,it)&
	419	*(1.-sij(i,k,j)) +ccntrENV_3d(i,k)&
	420	tr(i,k,it)sij(i,k,j)) / elij(i,k,j)
	421	ELSE
	422	qMeltmp(i,j,it)=0.
	423	ENDIF
	424	qpmMint(i,j,it)=qpmMint(i,j,it) + qMeltmp(i,j,it)*epmlmMm(i,j,k)
	425	Mint(i,j)=Mint(i,j) + epmlmMm(i,j,k)
	426	ENDIF ! end if dans nuage
	427	END DO
	428	END DO
	429	END DO
	430
	431	DO j=1,klev
	432	DO i=1,klon
[5082]	433	IF(Mint(i,j)>1.e-16) THEN
[2147]	434	qMel(i,j,it)=qpmMint(i,j,it)/Mint(i,j)
	435	ELSE
	436	qMel(i,j,it)=0.
	437	ENDIF
	438	END DO
	439	END DO
	440
	441	! calcul de q_d et q_p traceurs de la descente precipitante
	442	DO j=klev-1,1,-1
	443	DO i=1,klon
[5082]	444	IF(mp(i,j+1)>mp(i,j).AND.mp(i,j+1)>1.e-10) THEN ! detrainement
[2147]	445	kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
	446	(-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))&
	447	+ (imp(i,j)/RGdxpres(i,j))(evap(i,j)/RG*dxpres(i,j)))
	448
[5082]	449	ELSEIF(mp(i,j)>mp(i,j+1).AND.mp(i,j)>1.e-10) THEN! entrainement
	450	IF(j==1) THEN
[2147]	451	kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
	452	(-mp(i,2)-imp(i,j)/RG*dxpres(i,j))&
	453	+ (imp(i,j)/RGdxpres(i,j))(evap(i,j)/RG*dxpres(i,j)))
	454	ELSE
	455	kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
	456	(-mp(i,j)-imp(i,j)/RG*dxpres(i,j))&
	457	+ (imp(i,j)/RGdxpres(i,j))(evap(i,j)/RG*dxpres(i,j)))
	458	ENDIF
	459	ELSE
	460	kappa(i,j)=1.
	461	ENDIF
	462	ENDDO
	463	ENDDO
	464
	465	DO j=klev-1,1,-1
	466	DO i=1,klon
[5082]	467	IF (abs(kappa(i,j))<1.e-25) THEN !si denominateur nul (il peut y avoir des mp!=0)
[2147]	468	kappa(i,j)=1.
[5082]	469	IF(j==1) THEN
[2147]	470	qDi(i,j,it)=qDi(i,j+1,it) !orig tr(i,j,it) ! mp(1)=0 donc tout vient de la couche supérieure
[5082]	471	ELSEIF(mp(i,j+1)>mp(i,j).AND.mp(i,j+1)>1.e-10) THEN
[2147]	472	qDi(i,j,it)=qDi(i,j+1,it)
[5082]	473	ELSEIF(mp(i,j)>mp(i,j+1).AND.mp(i,j)>1.e-10) THEN! entrainement
[2147]	474	qDi(i,j,it)=(-mp(i,j+1)(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)tr(i,j,it))/(-mp(i,j))
	475	ELSE ! si mp (i)=0 et mp(j+1)=0
	476	qDi(i,j,it)=tr(i,j,it) ! orig 0.
	477	ENDIF
	478
	479	IF(NO_precip(i,j)) THEN
	480	qPr(i,j,it)=0.
	481	ELSE
	482	qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
	483	Pa(i,j)qPa(i,j,it)+Pm(i,j)qMel(i,j,it)&
	484	+imp(i,j)/RGdxpres(i,j)qDi(i,j,it))/&
	485	(pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
	486	ENDIF
	487	ELSE ! denominateur non nul
	488	kappa(i,j)=1./kappa(i,j)
	489	! calcul de qd et qp
	490	!!jyg (20130119) correction pour le sommet du nuage
[5116]	491	!! IF(j.GE.inb(i)) THEN !au-dessus du nuage, sommet inclu
	492	IF(j>inb(i)) THEN !au-dessus du nuage
[2147]	493	qDi(i,j,it)=tr(i,j,it) ! pas de descente => environnement = descente insaturee
	494	qPr(i,j,it)=0.
	495
	496	! vvv premiere couche du modele ou mp(1)=0 ! det tout le temps vvv
[5082]	497	ELSEIF(j==1) THEN
[5116]	498	IF(mp(i,2)>1.e-10) THEN !mp(2) non nul -> detrainement (car mp(1) = 0) !ent pas possible
	499	IF(NO_precip(i,j)) THEN !pas de precip en (i)
[2147]	500	qDi(i,j,it)=qDi(i,j+1,it)
	501	qPr(i,j,it)=0.
	502	ELSE
	503	qDi(i,j,it)=kappa(i,j)*(&
	504	(-evap(i,j)/RGdxpres(i,j))((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
	505	Pa(i,j)qPa(i,j,it)+Pm(i,j)qMel(i,j,it)) +&
	506	(pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
	507	(-mp(i,j+1)*qDi(i,j+1,it)))
	508
	509	qPr(i,j,it)=kappa(i,j)*(&
	510	(-mp(i,j+1)-imp(i,j)/RGdxpres(i,j))&
	511	((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
	512	Pa(i,j)qPa(i,j,it)+Pm(i,j)qMel(i,j,it))&
	513	+(-mp(i,j+1)qDi(i,j+1,it)) (imp(i,j)/RG*dxpres(i,j)))
	514	ENDIF
	515
	516	ELSE !mp(2) nul -> plus de descente insaturee -> pluie agit sur environnement
	517	qDi(i,j,it)=tr(i,j,it) ! orig 0.
[5116]	518	IF(NO_precip(i,j)) THEN
[2147]	519	qPr(i,j,it)=0.
	520	ELSE
	521	qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
	522	Pa(i,j)qPa(i,j,it)+Pm(i,j)qMel(i,j,it)&
	523	+imp(i,j)/RGdxpres(i,j)tr(i,j,it))/&
	524	(pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
	525	ENDIF
	526
	527	ENDIF !mp(2) nul ou non
	528
	529	! vvv (j!=1.AND.j.LT.inb(i)) en-dessous du sommet nuage vvv
	530	ELSE
	531	!------------------------------------------------------------- detrainement
[5116]	532	IF(mp(i,j+1)>mp(i,j).AND.mp(i,j+1)>1.e-10) THEN !mp(i,j).GT.1.e-10) THEN
	533	IF(NO_precip(i,j)) THEN
[2147]	534	qDi(i,j,it)=qDi(i,j+1,it)
	535	qPr(i,j,it)=0.
	536	ELSE
	537	qDi(i,j,it)=kappa(i,j)*(&
	538	(-evap(i,j)/RGdxpres(i,j))((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
	539	Pa(i,j)qPa(i,j,it)+Pm(i,j)qMel(i,j,it)) +&
	540	(pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
	541	(-mp(i,j+1)*qDi(i,j+1,it)))
[5099]	542
[2147]	543	qPr(i,j,it)=kappa(i,j)*(&
	544	(-mp(i,j+1)-imp(i,j)/RGdxpres(i,j))&
	545	((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
	546	Pa(i,j)qPa(i,j,it)+Pm(i,j)qMel(i,j,it))&
	547	+(-mp(i,j+1)qDi(i,j+1,it)) (imp(i,j)/RG*dxpres(i,j)))
	548	ENDIF !precip
	549	!------------------------------------------------------------- entrainement
[5082]	550	ELSEIF(mp(i,j)>mp(i,j+1).AND.mp(i,j)>1.e-10) THEN
[5116]	551	IF(NO_precip(i,j)) THEN
[2147]	552	qDi(i,j,it)=(-mp(i,j+1)(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)tr(i,j,it))/(-mp(i,j))
	553	qPr(i,j,it)=0.
	554	ELSE
	555	qDi(i,j,it)=kappa(i,j)*(&
	556	(-evap(i,j)/RGdxpres(i,j))((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
	557	Pa(i,j)qPa(i,j,it)+Pm(i,j)qMel(i,j,it)) +&
	558	(pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
	559	(-mp(i,j+1)(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)tr(i,j,it)))
[5099]	560
[2147]	561	qPr(i,j,it)=kappa(i,j)*(&
	562	(-mp(i,j)-imp(i,j)/RGdxpres(i,j))&
	563	((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
	564	Pa(i,j)qPa(i,j,it)+Pm(i,j)qMel(i,j,it))&
	565	+(-mp(i,j+1)(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)tr(i,j,it))*&
	566	(imp(i,j)/RG*dxpres(i,j)))
	567	ENDIF !precip
	568	!------------------------------------------------------------- ENDIF ! ent/det
	569	ELSE !mp nul
	570	qDi(i,j,it)=tr(i,j,it) ! orig 0.
[5116]	571	IF(NO_precip(i,j)) THEN
[2147]	572	qPr(i,j,it)=0.
	573	ELSE
	574	qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
	575	Pa(i,j)qPa(i,j,it)+Pm(i,j)qMel(i,j,it)&
	576	+imp(i,j)/RGdxpres(i,j)tr(i,j,it))/&
	577	(pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
	578	ENDIF
	579	ENDIF ! mp nul ou non
	580	ENDIF ! condition sur j
	581	ENDIF ! kappa
	582	ENDDO
	583	ENDDO
	584
	585	!! print test descente insaturee
	586	! DO j=klev,1,-1
	587	! DO i=1,klon
[5117]	588	! IF(it.EQ.3) THEN
[5116]	589	! WRITE(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') j,&
[2147]	590	!! 'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),&
	591	! 'zmfdam+zmfpsi',zmfdam(i,j,it)+zmfphi2(i,j,it),'qpmMint',qpmMint(i,j,it),&
	592	! 'Pm',Pm(i,j),'Mint',Mint(i,j),&
	593	!! 'zmfa',zmfa(i,j,it),'zmfp',zmfp(i,j,it),&
	594	! 'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),'zmfd1a',zmfd1a(i,j,it)
	595	!! 'Pa',Pa(i,j),'eplaMm',eplaMm(i,j)
	596	!! 'zmfd1a=da1qa',zmfd1a(i,j,it),'PaqPa',wdtrainA(i,j)*qPa(i,j,it),'da1',d1a(i,j)
	597	! ENDIF
	598	! ENDDO
	599	! ENDDO
	600
	601
	602	! ===================================================
	603	! calcul final des tendances
	604	! ===================================================
	605
	606	DO k=klev-1,1,-1
	607	DO i=1, klon
	608	! transport
	609	tdcvMA=zmfd(i,k,it)+zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it) ! double comptage des downdraft insatures
	610	trsptrac=zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)
	611	! lessivage courants satures
	612	!JE scavtrac=-ccntrAA_coef*zmfd1a(i,k,it)&
	613	!JE -zmfphi2(i,k,it)*ccntrENV_coef&
	614	!JE -zmfdam(i,k,it)*ccntrAA_coef
	615	scavtrac=-ccntrAA_3d(i,k)*zmfd1a(i,k,it)&
	616	-zmfphi2(i,k,it)*ccntrENV_3d(i,k)&
	617	-zmfdam(i,k,it)*ccntrAA_3d(i,k)
	618	! lessivage courants insatures
[5116]	619	IF(k<=inb(i).AND.k>1) THEN ! tendances dans le nuage
[2147]	620	!------------------------------------------------------------- detrainement
[5116]	621	IF(mp(i,k+1)>mp(i,k).AND.mp(i,k+1)>1.e-10) THEN
[2147]	622	uscavtrac= (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))&
	623	+ mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
[5099]	624
[5117]	625	! IF(it.EQ.3) WRITE(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' det incloud',&
[2147]	626	! (-mp(i,k)+mp(i,k+1))(qDi(i,k,it)-tr(i,k,it))pdtimeRG/dxpres(i,k)+&
	627	! mp(i,k)(tr(i,k-1,it)-tr(i,k,it))pdtimeRG/dxpres(i,k),&
	628	! 'mp',mp(i,k)
	629	!------------------------------------------------------------- entrainement
[5082]	630	ELSEIF(mp(i,k)>mp(i,k+1).AND.mp(i,k)>1.e-10) THEN
[2147]	631	uscavtrac= mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
[5099]	632
[5117]	633	! IF(it.EQ.3) WRITE(,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' ent incloud',uscavtracpdtimeRG/dxpres(i,k), 'mp',mp(i,k)
[2147]	634	!=!------------------------------------------------------------- end ent/det
	635	ELSE ! mp(i,k+1)=0. et mp(i,k)=0. pluie directement sur l environnement
	636
[5116]	637	IF(NO_precip(i,k)) THEN
[2147]	638	uscavtrac=0.
[5117]	639	! IF(it.EQ.3) WRITE(,'(I2,1X,a,e20.12,82X,a,e20.12)')k,' no P ent incloud',uscavtracpdtimeRG/dxpres(i,k), 'mp',mp(i,k)
[2147]	640	ELSE
	641	uscavtrac=-imp(i,k)tr(i,k,it)dxpres(i,k)/RG+evap(i,k)qPr(i,k,it)dxpres(i,k)/RG
[5117]	642	! IF(it.EQ.3) WRITE(,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtracpdtimeRG/dxpres(i,k), 'mp',mp(i,k)
[2147]	643	!!JE adds
[5117]	644	! IF(it.EQ.3) WRITE(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'imp',imp(i,k)
	645	! IF(it.EQ.3) WRITE(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'tr',tr(i,k,it)
	646	! IF(it.EQ.3) WRITE(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'evap',evap(i,k)
	647	! IF(it.EQ.3) WRITE(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'qPr',qPr(i,k,it)
	648	! IF(it.EQ.3) WRITE(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'dxpres',dxpres(i,k)
[2147]	649	!!Je end
	650
	651	ENDIF
	652	ENDIF ! mp/det/ent
	653	!------------------------------------------------------------- premiere couche
[5082]	654	ELSEIF(k==1) THEN ! mp(1)=0.
[5116]	655	IF(mp(i,2)>1.e-10) THEN !detrainement
[2147]	656	uscavtrac= (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it)) !&
	657	! + mp(i,2)*(0.-tr(i,k,it))
[5099]	658
[5117]	659	! IF(it.EQ.3) WRITE(*,'(I2,1X,a,e20.12,84X,a,e20.12)')k,' 1 det',&
[2147]	660	! (-0.+mp(i,2))(qDi(i,k,it)-tr(i,k,it))pdtimeRG/dxpres(i,k)+&
	661	! mp(i,2)(0.-tr(i,k,it))pdtimeRG/dxpres(i,k),&
	662	! 'mp',mp(i,k)
	663	ELSE ! mp(2) = 0 = mp(1) pas de descente insaturee, rien ne se passe s'il ne pleut pas, sinon pluie->env
[5116]	664	IF(NO_precip(i,1)) THEN
[2147]	665	uscavtrac=0.
	666	ELSE
	667	uscavtrac=-imp(i,k)tr(i,k,it)dxpres(i,k)/RG+evap(i,k)qPr(i,k,it)dxpres(i,k)/RG
	668	ENDIF
[5117]	669	! IF(it.EQ.3) WRITE(,'(I2,1X,a,2X,e20.12,82X,a,e20.12)')k,'1 P env incloud',uscavtracpdtimeRG/dxpres(i,k), 'mp',mp(i,k)
[2147]	670	ENDIF
	671
	672	ELSE ! k > INB au-dessus du nuage
	673	uscavtrac=0.
	674	ENDIF
	675
	676	! ===== tendances finales ======
	677	trsptd(i,k,it)=trsptrac*pdtimeRG/dxpres(i,k) ! td transport sans eau dans courants satures
	678	dtrSscav(i,k,it)=scavtrac*pdtimeRG/dxpres(i,k) ! td du lessivage dans courants satures
	679	dtrUscav(i,k,it)=uscavtrac*pdtimeRG/dxpres(i,k) ! td courant insat
	680	dtrsat(i,k,it)=(trsptrac+scavtrac)*pdtimeRG/dxpres(i,k) ! td courant sat
	681	dtrcv(i,k,it)=(trsptrac+scavtrac+uscavtrac)*pdtimeRG/dxpres(i,k)!dtrsat(i,k,it)+dtrUscav(i,k,it) td conv
	682	!!!!!!
	683	dtrcvMA(i,k,it)=tdcvMA*pdtimeRG/dxpres(i,k) ! MA tendance convection
	684	ENDDO
	685	ENDDO
	686
	687	! test de conservation du traceur
[5103]	688	!PRINT*,"_____________________________________________________________"
	689	!PRINT*," "
[2147]	690	! conserv=0.
	691	! conservMA=0.
	692	! DO k= klev-1,1,-1
	693	! DO i=1, klon
	694	! conserv=conserv+dtrcv(i,k,it)* &
	695	! (paprs(i,k)-paprs(i,k+1))/RG
	696	! conservMA=conservMA+dtrcvMA(i,k,it)* &
	697	! (paprs(i,k)-paprs(i,k+1))/RG
[5099]	698
[5117]	699	! IF(it.EQ.3) WRITE(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') k,&
[2147]	700	! 'MA td ',dtrcvMA(i,k,it)*dxpres(i,k)/RG,&
	701	! ' td',dtrcv(i,k,it)*dxpres(i,k)/RG,' conservMA ',conservMA,'conserv ',conserv
	702	!!
	703	! ENDDO
	704	! ENDDO
[5117]	705	! IF(it.EQ.3) print *,'it',it,'conserv ',conserv,'conservMA ',conservMA
[2147]	706
	707	END SUBROUTINE cvltr_scav

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

Download in other formats:

Original Format