Context Navigation

cv30_routines.F90 @ 4535

Last change on this file since 4535 was 4491, checked in by crisi, 19 months ago
Bug corrections in LMDZiso, especially for water tagging
Property svn:keywords set to `Id`
File size: 217.8 KB

Rev	Line
[3927]	1
[4004]	2	! $Id: cv30_routines.F90 4491 2023-04-03 08:25:44Z evignon $
[3927]	3
	4
	5
	6	SUBROUTINE cv30_param(nd, delt)
	7	IMPLICIT NONE
	8
	9	! ------------------------------------------------------------
	10	! Set parameters for convectL for iflag_con = 3
	11	! ------------------------------------------------------------
	12
	13
	14	! * PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE *
	15	! * PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO *
	16	! * PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. *
	17	! * EFFICIENCY IS ASSUMED TO BE UNITY *
	18	! * SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *
	19	! * SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *
	20	! * OF CLOUD *
	21
	22	! [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
	23	! * ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF *
	24	! * APPROACH TO QUASI-EQUILIBRIUM *
	25	! * (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) *
	26	! * (BETA MUST BE LESS THAN OR EQUAL TO 1) *
	27
	28	! * DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE *
	29	! * APPROACH TO QUASI-EQUILIBRIUM *
	30	! * IT MUST BE LESS THAN 0 *
	31
	32	include "cv30param.h"
	33	include "conema3.h"
	34
	35	INTEGER nd
	36	REAL delt ! timestep (seconds)
	37
	38	! noff: integer limit for convection (nd-noff)
	39	! minorig: First level of convection
	40
	41	! -- limit levels for convection:
	42
	43	noff = 1
	44	minorig = 1
	45	nl = nd - noff
	46	nlp = nl + 1
	47	nlm = nl - 1
	48
	49	! -- "microphysical" parameters:
	50
	51	sigd = 0.01
	52	spfac = 0.15
	53	pbcrit = 150.0
	54	ptcrit = 500.0
	55	! IM cf. FH epmax = 0.993
	56
	57	omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
	58
	59	! -- misc:
	60
	61	dtovsh = -0.2 ! dT for overshoot
	62	dpbase = -40. ! definition cloud base (400m above LCL)
	63	dttrig = 5. ! (loose) condition for triggering
	64
	65	! -- rate of approach to quasi-equilibrium:
	66
	67	dtcrit = -2.0
	68	tau = 8000.
	69	beta = 1.0 - delt/tau
	70	alpha = 1.5E-3*delt/tau
	71	! increase alpha to compensate W decrease:
	72	alpha = alpha*1.5
	73
	74	! -- interface cloud parameterization:
	75
	76	delta = 0.01 ! cld
	77
	78	! -- interface with boundary-layer (gust factor): (sb)
	79
	80	betad = 10.0 ! original value (from convect 4.3)
	81
	82	RETURN
	83	END SUBROUTINE cv30_param
	84
	85	SUBROUTINE cv30_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm, &
	86	th)
	87	IMPLICIT NONE
	88
	89	! =====================================================================
	90	! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
	91	! "ori": from convect4.3 (vectorized)
	92	! "convect3": to be exactly consistent with convect3
	93	! =====================================================================
	94
	95	! inputs:
	96	INTEGER len, nd, ndp1
	97	REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
	98
	99	! outputs:
	100	REAL lv(len, nd), cpn(len, nd), tv(len, nd)
	101	REAL gz(len, nd), h(len, nd), hm(len, nd)
	102	REAL th(len, nd)
	103
	104	! local variables:
	105	INTEGER k, i
	106	REAL rdcp
	107	REAL tvx, tvy ! convect3
	108	REAL cpx(len, nd)
	109
	110	include "cvthermo.h"
	111	include "cv30param.h"
	112
	113
	114	! ori do 110 k=1,nlp
	115	DO k = 1, nl ! convect3
	116	DO i = 1, len
	117	! debug lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
	118	lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15)
	119	cpn(i, k) = cpd(1.0-q(i,k)) + cpvq(i, k)
	120	cpx(i, k) = cpd(1.0-q(i,k)) + clq(i, k)
	121	! ori tv(i,k)=t(i,k)(1.0+q(i,k)epsim1)
	122	tv(i, k) = t(i, k)*(1.0+q(i,k)/eps-q(i,k))
	123	rdcp = (rrd(1.-q(i,k))+q(i,k)rrv)/cpn(i, k)
	124	th(i, k) = t(i, k)(1000.0/p(i,k))*rdcp
	125	END DO
	126	END DO
	127
	128	! gz = phi at the full levels (same as p).
	129
	130	DO i = 1, len
	131	gz(i, 1) = 0.0
	132	END DO
	133	! ori do 140 k=2,nlp
	134	DO k = 2, nl ! convect3
	135	DO i = 1, len
	136	tvx = t(i, k)*(1.+q(i,k)/eps-q(i,k)) !convect3
	137	tvy = t(i, k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
	138	gz(i, k) = gz(i, k-1) + 0.5rrd(tvx+tvy) & !convect3
	139	*(p(i,k-1)-p(i,k))/ph(i, k) !convect3
	140
	141	! ori gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
	142	! ori & *(p(i,k-1)-p(i,k))/ph(i,k)
	143	END DO
	144	END DO
	145
	146	! h = phi + cpT (dry static energy).
	147	! hm = phi + cp(T-Tbase)+Lq
	148
	149	! ori do 170 k=1,nlp
	150	DO k = 1, nl ! convect3
	151	DO i = 1, len
	152	h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
	153	hm(i, k) = gz(i, k) + cpx(i, k)(t(i,k)-t(i,1)) + lv(i, k)q(i, k)
	154	END DO
	155	END DO
	156
	157	RETURN
	158	END SUBROUTINE cv30_prelim
	159
	160	SUBROUTINE cv30_feed(len, nd, t, q, qs, p, ph, hm, gz, nk, icb, icbmax, &
	161	iflag, tnk, qnk, gznk, plcl &
	162	#ifdef ISO
	163	,xt,xtnk &
	164	#endif
	165	)
	166	#ifdef ISO
[4143]	167	USE infotrac_phy, ONLY: ntraciso=>ntiso
[3927]	168	#endif
	169	IMPLICIT NONE
	170
	171	! ================================================================
	172	! Purpose: CONVECTIVE FEED
	173
	174	! Main differences with cv_feed:
	175	! - ph added in input
	176	! - here, nk(i)=minorig
	177	! - icb defined differently (plcl compared with ph instead of p)
	178
	179	! Main differences with convect3:
	180	! - we do not compute dplcldt and dplcldr of CLIFT anymore
	181	! - values iflag different (but tests identical)
	182	! - A,B explicitely defined (!...)
	183	! ================================================================
	184
	185	include "cv30param.h"
	186
	187	! inputs:
	188	INTEGER len, nd
	189	REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd)
	190	REAL hm(len, nd), gz(len, nd)
	191	REAL ph(len, nd+1)
	192	#ifdef ISO
	193	real xt(ntraciso,len,nd)
	194	#endif
	195
	196	! outputs:
	197	INTEGER iflag(len), nk(len), icb(len), icbmax
	198	REAL tnk(len), qnk(len), gznk(len), plcl(len)
	199	#ifdef ISO
	200	real xtnk(ntraciso,len)
	201	#endif
	202
	203	! local variables:
	204	INTEGER i, k
	205	#ifdef ISO
	206	integer ixt
	207	#endif
	208	INTEGER ihmin(len)
	209	REAL work(len)
	210	REAL pnk(len), qsnk(len), rh(len), chi(len)
	211	REAL a, b ! convect3
	212	! ym
	213	plcl = 0.0
	214	! @ !-------------------------------------------------------------------
	215	! @ ! --- Find level of minimum moist static energy
	216	! @ ! --- If level of minimum moist static energy coincides with
	217	! @ ! --- or is lower than minimum allowable parcel origin level,
	218	! @ ! --- set iflag to 6.
	219	! @ !-------------------------------------------------------------------
	220	! @
	221	! @ do 180 i=1,len
	222	! @ work(i)=1.0e12
	223	! @ ihmin(i)=nl
	224	! @ 180 continue
	225	! @ do 200 k=2,nlp
	226	! @ do 190 i=1,len
	227	! @ if((hm(i,k).lt.work(i)).and.
	228	! @ & (hm(i,k).lt.hm(i,k-1)))then
	229	! @ work(i)=hm(i,k)
	230	! @ ihmin(i)=k
	231	! @ endif
	232	! @ 190 continue
	233	! @ 200 continue
	234	! @ do 210 i=1,len
	235	! @ ihmin(i)=min(ihmin(i),nlm)
	236	! @ if(ihmin(i).le.minorig)then
	237	! @ iflag(i)=6
	238	! @ endif
	239	! @ 210 continue
	240	! @ c
	241	! @ !-------------------------------------------------------------------
	242	! @ ! --- Find that model level below the level of minimum moist static
	243	! @ ! --- energy that has the maximum value of moist static energy
	244	! @ !-------------------------------------------------------------------
	245	! @
	246	! @ do 220 i=1,len
	247	! @ work(i)=hm(i,minorig)
	248	! @ nk(i)=minorig
	249	! @ 220 continue
	250	! @ do 240 k=minorig+1,nl
	251	! @ do 230 i=1,len
	252	! @ if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
	253	! @ work(i)=hm(i,k)
	254	! @ nk(i)=k
	255	! @ endif
	256	! @ 230 continue
	257	! @ 240 continue
	258
	259	! -------------------------------------------------------------------
	260	! --- Origin level of ascending parcels for convect3:
	261	! -------------------------------------------------------------------
	262
	263	DO i = 1, len
	264	nk(i) = minorig
	265	END DO
	266
	267	! -------------------------------------------------------------------
	268	! --- Check whether parcel level temperature and specific humidity
	269	! --- are reasonable
	270	! -------------------------------------------------------------------
	271	DO i = 1, len
	272	IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0)) & ! @ & .or.(
	273	! p(i,ihmin(i)).lt.400.0
	274	! ) )
	275	.AND. (iflag(i)==0)) iflag(i) = 7
	276	END DO
	277	! -------------------------------------------------------------------
	278	! --- Calculate lifted condensation level of air at parcel origin level
	279	! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
	280	! -------------------------------------------------------------------
	281
	282	a = 1669.0 ! convect3
	283	b = 122.0 ! convect3
	284
	285	DO i = 1, len
	286
	287	IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
	288
	289	tnk(i) = t(i, nk(i))
	290	qnk(i) = q(i, nk(i))
	291	gznk(i) = gz(i, nk(i))
	292	pnk(i) = p(i, nk(i))
	293	qsnk(i) = qs(i, nk(i))
	294	#ifdef ISO
	295	do ixt=1,ntraciso
	296	xtnk(ixt,i) = xt(ixt,i, nk(i))
	297	enddo
	298	#endif
	299
	300	rh(i) = qnk(i)/qsnk(i)
	301	! ori rh(i)=min(1.0,rh(i)) ! removed for convect3
	302	! ori chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
	303	chi(i) = tnk(i)/(a-b*rh(i)-tnk(i)) ! convect3
	304	plcl(i) = pnk(i)(rh(i)*chi(i))
	305	IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag &
	306	(i) = 8
	307
	308	END IF ! iflag=7
	309
	310	END DO
	311
	312	! -------------------------------------------------------------------
	313	! --- Calculate first level above lcl (=icb)
	314	! -------------------------------------------------------------------
	315
	316	! @ do 270 i=1,len
	317	! @ icb(i)=nlm
	318	! @ 270 continue
	319	! @c
	320	! @ do 290 k=minorig,nl
	321	! @ do 280 i=1,len
	322	! @ if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
	323	! @ & icb(i)=min(icb(i),k)
	324	! @ 280 continue
	325	! @ 290 continue
	326	! @c
	327	! @ do 300 i=1,len
	328	! @ if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
	329	! @ 300 continue
	330
	331	DO i = 1, len
	332	icb(i) = nlm
	333	END DO
	334
	335	! la modification consiste a comparer plcl a ph et non a p:
	336	! icb est defini par : ph(icb)<plcl<ph(icb-1)
	337	! @ do 290 k=minorig,nl
	338	DO k = 3, nl - 1 ! modif pour que icb soit sup/egal a 2
	339	DO i = 1, len
	340	IF (ph(i,k)<plcl(i)) icb(i) = min(icb(i), k)
	341	END DO
	342	END DO
	343
	344	DO i = 1, len
	345	! @ if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
	346	IF ((icb(i)==nlm) .AND. (iflag(i)==0)) iflag(i) = 9
	347	END DO
	348
	349	DO i = 1, len
	350	icb(i) = icb(i) - 1 ! icb sup ou egal a 2
	351	END DO
	352
	353	! Compute icbmax.
	354
	355	icbmax = 2
	356	DO i = 1, len
	357	! ! icbmax=max(icbmax,icb(i))
	358	IF (iflag(i)<7) icbmax = max(icbmax, icb(i)) ! sb Jun7th02
	359	END DO
	360
	361	RETURN
	362	END SUBROUTINE cv30_feed
	363
	364	SUBROUTINE cv30_undilute1(len, nd, t, q, qs, gz, plcl, p, nk, icb, tp, tvp, &
	365	clw, icbs &
	366	#ifdef ISO
	367	& ,xt,xtclw &
	368	#endif
	369	& )
	370
	371	#ifdef ISO
[4143]	372	USE infotrac_phy, ONLY: ntraciso=>ntiso
[3927]	373	USE isotopes_mod, ONLY: pxtmelt,pxtice,pxtmin,pxtmax,cond_temp_env, &
	374	iso_eau,iso_HDO, ridicule
	375	USE isotopes_routines_mod, ONLY: condiso_liq_ice_vectall
	376	#ifdef ISOTRAC
	377	USE isotopes_routines_mod, ONLY: condiso_liq_ice_vectall_trac
	378	#ifdef ISOVERIF
	379	use isotopes_verif_mod, ONLY: iso_verif_traceur
	380	#endif
	381	#endif
	382	#ifdef ISOVERIF
	383	use isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif, &
	384	iso_verif_egalite_choix, iso_verif_noNaN,iso_verif_aberrant, &
	385	iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
	386	iso_verif_egalite_nostop,iso_verif_aberrant_nostop,deltaD,iso_verif_noNaN_nostop, &
	387	iso_verif_positif,iso_verif_egalite_vect2D
	388	#endif
	389	#endif
	390
	391	IMPLICIT NONE
	392
	393	! ----------------------------------------------------------------
	394	! Equivalent de TLIFT entre NK et ICB+1 inclus
	395
	396	! Differences with convect4:
	397	! - specify plcl in input
	398	! - icbs is the first level above LCL (may differ from icb)
	399	! - in the iterations, used x(icbs) instead x(icb)
	400	! - many minor differences in the iterations
	401	! - tvp is computed in only one time
	402	! - icbs: first level above Plcl (IMIN de TLIFT) in output
	403	! - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
	404	! ----------------------------------------------------------------
	405
	406	include "cvthermo.h"
	407	include "cv30param.h"
	408
	409	! inputs:
	410	INTEGER len, nd
	411	INTEGER nk(len), icb(len)
	412	REAL t(len, nd), q(len, nd), qs(len, nd), gz(len, nd)
	413	REAL p(len, nd)
	414	REAL plcl(len) ! convect3
	415	#ifdef ISO
	416	real xt(ntraciso,len,nd)
	417	#endif
	418
	419	! outputs:
	420	REAL tp(len, nd), tvp(len, nd), clw(len, nd)
	421	#ifdef ISO
	422	real xtclw(ntraciso,len,nd)
	423	real tg_save(len,nd)
	424	#endif
	425
	426	! local variables:
	427	INTEGER i, k
	428	INTEGER icb1(len), icbs(len), icbsmax2 ! convect3
	429	REAL tg, qg, alv, s, ahg, tc, denom, es, rg
	430	REAL ah0(len), cpp(len)
	431	REAL tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
	432	REAL qsicb(len) ! convect3
	433	REAL cpinv(len) ! convect3
	434	#ifdef ISO
	435	integer ixt
	436	real zfice(len),zxtliq(ntraciso,len),zxtice(ntraciso,len)
	437	real q_k(len),clw_k(len),tg_k(len),xt_k(ntraciso,len)
	438	!#ifdef ISOVERIF
	439	! integer iso_verif_positif_nostop
	440	!#endif
	441	#endif
	442
	443	! -------------------------------------------------------------------
	444	! --- Calculates the lifted parcel virtual temperature at nk,
	445	! --- the actual temperature, and the adiabatic
	446	! --- liquid water content. The procedure is to solve the equation.
	447	! cptp+Lqp+phi=cptnk+Lqnk+gznk.
	448	! -------------------------------------------------------------------
	449
	450	#ifdef ISOVERIF
[4050]	451	write(,) 'cv30_routine undilute 1 413: entree'
[3927]	452	#endif
	453
	454	DO i = 1, len
	455	tnk(i) = t(i, nk(i))
	456	qnk(i) = q(i, nk(i))
	457	gznk(i) = gz(i, nk(i))
	458	! ori ticb(i)=t(i,icb(i))
	459	! ori gzicb(i)=gz(i,icb(i))
	460	END DO
	461
	462	! * Calculate certain parcel quantities, including static energy *
	463
	464	DO i = 1, len
	465	ah0(i) = (cpd(1.-qnk(i))+clqnk(i))tnk(i) + qnk(i)(lv0-clmcpv*(tnk(i)- &
	466	273.15)) + gznk(i)
	467	cpp(i) = cpd(1.-qnk(i)) + qnk(i)cpv
	468	cpinv(i) = 1./cpp(i)
	469	END DO
	470
	471	! * Calculate lifted parcel quantities below cloud base *
	472
	473	DO i = 1, len !convect3
	474	icb1(i) = min(max(icb(i), 2), nl)
	475	! if icb is below LCL, start loop at ICB+1:
	476	! (icbs est le premier niveau au-dessus du LCL)
	477	icbs(i) = icb1(i) !convect3
	478	IF (plcl(i)<p(i,icb1(i))) THEN
	479	icbs(i) = min(icbs(i)+1, nl) !convect3
	480	END IF
	481	END DO !convect3
	482
	483	DO i = 1, len !convect3
	484	ticb(i) = t(i, icbs(i)) !convect3
	485	gzicb(i) = gz(i, icbs(i)) !convect3
	486	qsicb(i) = qs(i, icbs(i)) !convect3
	487	END DO !convect3
	488
	489
	490	! Re-compute icbsmax (icbsmax2): !convect3
	491	! !convect3
	492	icbsmax2 = 2 !convect3
	493	DO i = 1, len !convect3
	494	icbsmax2 = max(icbsmax2, icbs(i)) !convect3
	495	END DO !convect3
	496
	497	! initialization outputs:
	498
	499	DO k = 1, icbsmax2 ! convect3
	500	DO i = 1, len ! convect3
	501	tp(i, k) = 0.0 ! convect3
	502	tvp(i, k) = 0.0 ! convect3
	503	clw(i, k) = 0.0 ! convect3
	504	#ifdef ISO
	505	do ixt=1,ntraciso
	506	xtclw(ixt,i,k) = 0.0
	507	enddo
	508
	509	#endif
	510	END DO ! convect3
	511	END DO ! convect3
	512
	513
	514	! tp and tvp below cloud base:
	515
	516	DO k = minorig, icbsmax2 - 1
	517	DO i = 1, len
	518	tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))*cpinv(i)
	519	tvp(i, k) = tp(i, k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
	520	END DO
	521	END DO
	522
	523	! * Find lifted parcel quantities above cloud base *
	524
	525	DO i = 1, len
	526	tg = ticb(i)
	527	! ori qg=qs(i,icb(i))
	528	qg = qsicb(i) ! convect3
	529	! debug alv=lv0-clmcpv*(ticb(i)-t0)
	530	alv = lv0 - clmcpv*(ticb(i)-273.15)
	531
	532	! First iteration.
	533
	534	! ori s=cpd+alvalvqg/(rrvticb(i)ticb(i))
	535	s = cpd(1.-qnk(i)) + clqnk(i) & ! convect3
	536	+alvalvqg/(rrvticb(i)ticb(i)) ! convect3
	537	s = 1./s
	538	! ori ahg=cpdtg+(cl-cpd)qnk(i)ticb(i)+alvqg+gzicb(i)
	539	ahg = cpdtg + (cl-cpd)qnk(i)tg + alvqg + gzicb(i) ! convect3
	540	tg = tg + s*(ah0(i)-ahg)
	541	! ori tg=max(tg,35.0)
	542	! debug tc=tg-t0
	543	tc = tg - 273.15
	544	denom = 243.5 + tc
	545	denom = max(denom, 1.0) ! convect3
	546	! ori if(tc.ge.0.0)then
	547	es = 6.112exp(17.67tc/denom)
	548	! ori else
	549	! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
	550	! ori endif
	551	! ori qg=epses/(p(i,icb(i))-es(1.-eps))
	552	qg = epses/(p(i,icbs(i))-es(1.-eps))
	553	! qg=max(0.0,qg) ! C Risi
	554
	555	! Second iteration.
	556
	557
	558	! ori s=cpd+alvalvqg/(rrvticb(i)ticb(i))
	559	! ori s=1./s
	560	! ori ahg=cpdtg+(cl-cpd)qnk(i)ticb(i)+alvqg+gzicb(i)
	561	ahg = cpdtg + (cl-cpd)qnk(i)tg + alvqg + gzicb(i) ! convect3
	562	tg = tg + s*(ah0(i)-ahg)
	563	! ori tg=max(tg,35.0)
	564	! debug tc=tg-t0
	565	tc = tg - 273.15
	566	denom = 243.5 + tc
	567	denom = max(denom, 1.0) ! convect3
	568	! ori if(tc.ge.0.0)then
	569	es = 6.112exp(17.67tc/denom)
	570	! ori else
	571	! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
	572	! ori end if
	573	! ori qg=epses/(p(i,icb(i))-es(1.-eps))
	574	qg = epses/(p(i,icbs(i))-es(1.-eps))
	575	! qg=max(0.0,qg) ! C Risi
	576
	577	alv = lv0 - clmcpv*(ticb(i)-273.15)
	578
	579	! ori c approximation here:
	580	! ori tp(i,icb(i))=(ah0(i)-(cl-cpd)qnk(i)ticb(i)
	581	! ori & -gz(i,icb(i))-alv*qg)/cpd
	582
	583	! convect3: no approximation:
	584	tp(i, icbs(i)) = (ah0(i)-gz(i,icbs(i))-alvqg)/(cpd+(cl-cpd)qnk(i))
	585
	586	! ori clw(i,icb(i))=qnk(i)-qg
	587	! ori clw(i,icb(i))=max(0.0,clw(i,icb(i)))
	588	clw(i, icbs(i)) = qnk(i) - qg
	589	clw(i, icbs(i)) = max(0.0, clw(i,icbs(i)))
	590
	591	rg = qg/(1.-qnk(i))
	592	! ori tvp(i,icb(i))=tp(i,icb(i))(1.+rgepsi)
	593	! convect3: (qg utilise au lieu du vrai mixing ratio rg)
	594	tvp(i, icbs(i)) = tp(i, icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
	595
	596	END DO
	597
	598	#ifdef ISO
	599	! calcul de zfice
	600	do i=1,len
	601	zfice(i) = 1.0-(t(i,icbs(i))-pxtice)/(pxtmelt-pxtice)
	602	zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
	603	enddo
[4050]	604	! calcul de la composition du condensat glace et liquide
[3927]	605
	606	do i=1,len
	607	clw_k(i)=clw(i,icbs(i))
	608	tg_k(i)=t(i,icbs(i))
	609	do ixt=1,ntraciso
	610	xt_k(ixt,i)=xt(ixt,i,nk(i))
	611	enddo
	612	enddo
	613	#ifdef ISOVERIF
	614	write(,) 'cv30_routine undilute1 573: avant condiso'
	615	write(,) 't(1,1)=',t(1,1)
	616	do i=1,len
	617	call iso_verif_positif(t(i,icbs(i))-Tmin_verif, &
	618	& 'cv30_routines 654')
	619	enddo
	620	if (iso_HDO.gt.0) then
	621	do i=1,len
	622	if (qnk(i).gt.ridicule) then
	623	call iso_verif_aberrant(xt_k(iso_hdo,i)/qnk(i), &
	624	& 'cv30_routines 576')
	625	endif !if (qnk(i).gt.ridicule) then
	626	enddo
	627	endif !if (iso_HDO.gt.0) then
	628	! write(,) 'i=1, clw_k,qnk=',clw_k(1),qnk(1)
	629	#endif
	630	call condiso_liq_ice_vectall(xt_k(1,1),qnk(1), &
	631	& clw_k(1),tg_k(1), &
	632	& zfice(1),zxtice(1,1),zxtliq(1,1),len)
	633	#ifdef ISOTRAC
	634	#ifdef ISOVERIF
	635	write(,) 'cv30_routines 658: call condiso_liq_ice_vectall_trac'
	636	#endif
	637	call condiso_liq_ice_vectall_trac(xt_k(1,1),qnk(1), &
	638	& clw_k(1),tg_k(1), &
	639	& zfice(1),zxtice(1,1),zxtliq(1,1),len)
	640	#endif
	641	do i=1,len
	642	do ixt = 1, ntraciso
	643	xtclw(ixt,i,icbs(i))= zxtice(ixt,i)+zxtliq(ixt,i)
	644	xtclw(ixt,i,icbs(i))=max(0.0,xtclw(ixt,i,icbs(i)))
	645	enddo !do ixt=1,niso
	646	enddo !do i=1,len
	647
	648	#ifdef ISOVERIF
[4050]	649	write(,) 'cv30_routine undilute 1 598: apres condiso'
[3927]	650
	651	if (iso_eau.gt.0) then
	652	do i=1,len
	653	call iso_verif_egalite_choix(xtclw(iso_eau,i,icbs(i)), &
	654	& clw(i,icbs(i)),'cv30_routines 577',errmax,errmaxrel)
	655	enddo !do i=1,len
	656	endif !if (iso_eau.gt.0) then
	657	#ifdef ISOTRAC
	658	do i=1,len
	659	call iso_verif_traceur(xtclw(1,i,k),'cv30_routines 603')
	660	enddo
	661	#endif
	662
	663	#endif
	664	#endif
	665
	666	! ori do 380 k=minorig,icbsmax2
	667	! ori do 370 i=1,len
	668	! ori tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
	669	! ori 370 continue
	670	! ori 380 continue
	671
	672
	673	! -- The following is only for convect3:
	674
	675	! * icbs is the first level above the LCL:
	676	! if plcl<p(icb), then icbs=icb+1
	677	! if plcl>p(icb), then icbs=icb
	678
	679	! * the routine above computes tvp from minorig to icbs (included).
	680
	681	! * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
	682	! must be known. This is the case if icbs=icb+1, but not if icbs=icb.
	683
	684	! * therefore, in the case icbs=icb, we compute tvp at level icb+1
	685	! (tvp at other levels will be computed in cv3_undilute2.F)
	686
	687
	688	DO i = 1, len
	689	ticb(i) = t(i, icb(i)+1)
	690	gzicb(i) = gz(i, icb(i)+1)
	691	qsicb(i) = qs(i, icb(i)+1)
	692	END DO
	693
	694	DO i = 1, len
	695	tg = ticb(i)
	696	qg = qsicb(i) ! convect3
	697	! debug alv=lv0-clmcpv*(ticb(i)-t0)
	698	alv = lv0 - clmcpv*(ticb(i)-273.15)
	699
	700	! First iteration.
	701
	702	! ori s=cpd+alvalvqg/(rrvticb(i)ticb(i))
	703	s = cpd(1.-qnk(i)) + clqnk(i) & ! convect3
	704	+alvalvqg/(rrvticb(i)ticb(i)) ! convect3
	705	s = 1./s
	706	! ori ahg=cpdtg+(cl-cpd)qnk(i)ticb(i)+alvqg+gzicb(i)
	707	ahg = cpdtg + (cl-cpd)qnk(i)tg + alvqg + gzicb(i) ! convect3
	708	tg = tg + s*(ah0(i)-ahg)
	709	! ori tg=max(tg,35.0)
	710	! debug tc=tg-t0
	711	tc = tg - 273.15
	712	denom = 243.5 + tc
	713	denom = max(denom, 1.0) ! convect3
	714	! ori if(tc.ge.0.0)then
	715	es = 6.112exp(17.67tc/denom)
	716	! ori else
	717	! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
	718	! ori endif
	719	! ori qg=epses/(p(i,icb(i))-es(1.-eps))
	720	qg = epses/(p(i,icb(i)+1)-es(1.-eps))
	721	! qg=max(0.0,qg) ! C Risi
	722
	723	! Second iteration.
	724
	725
	726	! ori s=cpd+alvalvqg/(rrvticb(i)ticb(i))
	727	! ori s=1./s
	728	! ori ahg=cpdtg+(cl-cpd)qnk(i)ticb(i)+alvqg+gzicb(i)
	729	ahg = cpdtg + (cl-cpd)qnk(i)tg + alvqg + gzicb(i) ! convect3
	730	tg = tg + s*(ah0(i)-ahg)
	731	! ori tg=max(tg,35.0)
	732	! debug tc=tg-t0
	733	tc = tg - 273.15
	734	denom = 243.5 + tc
	735	denom = max(denom, 1.0) ! convect3
	736	! ori if(tc.ge.0.0)then
	737	es = 6.112exp(17.67tc/denom)
	738	! ori else
	739	! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
	740	! ori end if
	741	! ori qg=epses/(p(i,icb(i))-es(1.-eps))
	742	qg = epses/(p(i,icb(i)+1)-es(1.-eps))
	743	! qg=max(0.0,qg) ! C Risi
	744
	745
	746	alv = lv0 - clmcpv*(ticb(i)-273.15)
	747
	748	! ori c approximation here:
	749	! ori tp(i,icb(i))=(ah0(i)-(cl-cpd)qnk(i)ticb(i)
	750	! ori & -gz(i,icb(i))-alv*qg)/cpd
	751
	752	! convect3: no approximation:
	753	tp(i, icb(i)+1) = (ah0(i)-gz(i,icb(i)+1)-alvqg)/(cpd+(cl-cpd)qnk(i))
	754
	755	! ori clw(i,icb(i))=qnk(i)-qg
	756	! ori clw(i,icb(i))=max(0.0,clw(i,icb(i)))
	757	clw(i, icb(i)+1) = qnk(i) - qg
	758	clw(i, icb(i)+1) = max(0.0, clw(i,icb(i)+1))
	759
	760	rg = qg/(1.-qnk(i))
	761	! ori tvp(i,icb(i))=tp(i,icb(i))(1.+rgepsi)
	762	! convect3: (qg utilise au lieu du vrai mixing ratio rg)
	763	tvp(i, icb(i)+1) = tp(i, icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
	764
	765	END DO
	766
	767
	768
	769	#ifdef ISO
	770	do i=1,len
	771	zfice(i) = 1.0-(t(i,icb(i)+1)-pxtice)/(pxtmelt-pxtice)
	772	zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
	773	! call calcul_zfice(tp(i,icb(i)+1),zfice)
	774	enddo !do i=1,len
	775	do i=1,len
	776	clw_k(i)=clw(i,icb(i)+1)
	777	tg_k(i)=t(i,icb(i)+1)
	778	#ifdef ISOVERIF
	779	call iso_verif_positif(tg_k(i)-Tmin_verif,'cv30_routines 750')
	780	#endif
	781	do ixt=1,ntraciso
	782	xt_k(ixt,i)=xt(ixt,i,nk(i))
	783	enddo
	784	enddo !do i=1,len
	785	#ifdef ISOVERIF
	786	write(,) 'cv30_routines 739: avant condiso'
	787	if (iso_HDO.gt.0) then
	788	do i=1,len
	789	call iso_verif_aberrant(xt_k(iso_hdo,i)/qnk(i), &
	790	& 'cv30_routines 725')
	791	enddo
	792	endif !if (iso_HDO.gt.0) then
	793	#ifdef ISOTRAC
	794	do i=1,len
	795	call iso_verif_traceur(xtclw(1,i,k),'cv30_routines 738')
	796	enddo
	797	#endif
	798	#endif
	799	call condiso_liq_ice_vectall(xt_k(1,1),qnk(1), &
	800	& clw_k(1),tg_k(1), &
	801	& zfice(1),zxtice(1,1),zxtliq(1,1),len)
	802	#ifdef ISOTRAC
	803	call condiso_liq_ice_vectall_trac(xt_k(1,1),qnk(1), &
	804	& clw_k(1),tg_k(1), &
	805	& zfice(1),zxtice(1,1),zxtliq(1,1),len)
	806	#endif
	807	do i=1,len
	808	do ixt = 1, ntraciso
	809	xtclw(ixt,i,icb(i)+1)=zxtice(ixt,i)+zxtliq(ixt,i)
	810	xtclw(ixt,i,icb(i)+1)=max(0.0,xtclw(ixt,i,icb(i)+1))
	811	enddo !do ixt = 1, niso
	812	enddo !do i=1,len
	813
	814	#ifdef ISOVERIF
	815	!write(,) 'DEBUG ISO B'
	816	do i=1,len
	817	if (iso_eau.gt.0) then
	818	call iso_verif_egalite_choix(xtclw(iso_eau,i,icb(i)+1), &
	819	& clw(i,icb(i)+1),'cv30_routines 708',errmax,errmaxrel)
	820	endif ! if (iso_eau.gt.0) then
	821	#ifdef ISOTRAC
	822	call iso_verif_traceur(xtclw(1,i,icb(i)+1), &
	823	& 'cv30_routines 760')
	824	#endif
	825	enddo !do i=1,len
	826	!write(,) 'FIN DEBUG ISO B'
	827	#endif
	828	#endif
	829
	830	RETURN
	831	END SUBROUTINE cv30_undilute1
	832
	833	SUBROUTINE cv30_trigger(len, nd, icb, plcl, p, th, tv, tvp, pbase, buoybase, &
	834	iflag, sig, w0)
	835	IMPLICIT NONE
	836
	837	! -------------------------------------------------------------------
	838	! --- TRIGGERING
	839
	840	! - computes the cloud base
	841	! - triggering (crude in this version)
	842	! - relaxation of sig and w0 when no convection
	843
	844	! Caution1: if no convection, we set iflag=4
	845	! (it used to be 0 in convect3)
	846
	847	! Caution2: at this stage, tvp (and thus buoy) are know up
	848	! through icb only!
	849	! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
	850	! -------------------------------------------------------------------
	851
	852	include "cv30param.h"
	853
	854	! input:
	855	INTEGER len, nd
	856	INTEGER icb(len)
	857	REAL plcl(len), p(len, nd)
	858	REAL th(len, nd), tv(len, nd), tvp(len, nd)
	859
	860	! output:
	861	REAL pbase(len), buoybase(len)
	862
	863	! input AND output:
	864	INTEGER iflag(len)
	865	REAL sig(len, nd), w0(len, nd)
	866
	867	! local variables:
	868	INTEGER i, k
	869	REAL tvpbase, tvbase, tdif, ath, ath1
	870
	871
	872	! *** set cloud base buoyancy at (plcl+dpbase) level buoyancy
	873
	874	DO i = 1, len
	875	pbase(i) = plcl(i) + dpbase
	876	tvpbase = tvp(i, icb(i))*(pbase(i)-p(i,icb(i)+1))/ &
	877	(p(i,icb(i))-p(i,icb(i)+1)) + tvp(i, icb(i)+1)*(p(i,icb(i))-pbase(i))/( &
	878	p(i,icb(i))-p(i,icb(i)+1))
	879	tvbase = tv(i, icb(i))*(pbase(i)-p(i,icb(i)+1))/ &
	880	(p(i,icb(i))-p(i,icb(i)+1)) + tv(i, icb(i)+1)*(p(i,icb(i))-pbase(i))/(p &
	881	(i,icb(i))-p(i,icb(i)+1))
	882	buoybase(i) = tvpbase - tvbase
	883	END DO
	884
	885
	886	! * make sure that column is dry adiabatic between the surface *
	887	! * and cloud base, and that lifted air is positively buoyant *
	888	! * at cloud base *
	889	! * if not, return to calling program after resetting *
	890	! * sig(i) and w0(i) *
	891
	892
	893	! oct3 do 200 i=1,len
	894	! oct3
	895	! oct3 tdif = buoybase(i)
	896	! oct3 ath1 = th(i,1)
	897	! oct3 ath = th(i,icb(i)-1) - dttrig
	898	! oct3
	899	! oct3 if (tdif.lt.dtcrit .or. ath.gt.ath1) then
	900	! oct3 do 60 k=1,nl
	901	! oct3 sig(i,k) = betasig(i,k) - 2.alphatdiftdif
	902	! oct3 sig(i,k) = AMAX1(sig(i,k),0.0)
	903	! oct3 w0(i,k) = beta*w0(i,k)
	904	! oct3 60 continue
	905	! oct3 iflag(i)=4 ! pour version vectorisee
	906	! oct3c convect3 iflag(i)=0
	907	! oct3cccc return
	908	! oct3 endif
	909	! oct3
	910	! oct3200 continue
	911
	912	! -- oct3: on reecrit la boucle 200 (pour la vectorisation)
	913
	914	DO k = 1, nl
	915	DO i = 1, len
	916
	917	tdif = buoybase(i)
	918	ath1 = th(i, 1)
	919	ath = th(i, icb(i)-1) - dttrig
	920
	921	IF (tdif<dtcrit .OR. ath>ath1) THEN
	922	sig(i, k) = betasig(i, k) - 2.alphatdiftdif
	923	sig(i, k) = amax1(sig(i,k), 0.0)
	924	w0(i, k) = beta*w0(i, k)
	925	iflag(i) = 4 ! pour version vectorisee
	926	! convect3 iflag(i)=0
	927	END IF
	928
	929	END DO
	930	END DO
	931
	932	! fin oct3 --
	933
	934	RETURN
	935	END SUBROUTINE cv30_trigger
	936
	937	SUBROUTINE cv30_compress(len, nloc, ncum, nd, ntra, iflag1, nk1, icb1, icbs1, &
	938	plcl1, tnk1, qnk1, gznk1, pbase1, buoybase1, t1, q1, qs1, u1, v1, gz1, &
	939	th1, tra1, h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, sig1, w01, &
	940	iflag, nk, icb, icbs, plcl, tnk, qnk, gznk, pbase, buoybase, t, q, qs, u, &
	941	v, gz, th, tra, h, lv, cpn, p, ph, tv, tp, tvp, clw, sig, w0 &
	942	#ifdef ISO
	943	& ,xtnk1,xt1,xtclw1 &
	944	& ,xtnk,xt,xtclw &
	945	#endif
	946	& )
	947	USE print_control_mod, ONLY: lunout
	948	#ifdef ISO
[4143]	949	use infotrac_phy, ONLY: ntraciso=>ntiso
[3927]	950	use isotopes_mod, ONLY: essai_convergence, iso_eau,iso_HDO
	951	#ifdef ISOVERIF
	952	use isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif, &
	953	iso_verif_egalite_choix, iso_verif_noNaN,iso_verif_aberrant, &
	954	iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
	955	iso_verif_egalite_nostop,iso_verif_aberrant_nostop,deltaD,iso_verif_noNaN_nostop, &
	956	iso_verif_positif,iso_verif_egalite_vect2D
	957	#endif
	958	#endif
	959	IMPLICIT NONE
	960
	961	include "cv30param.h"
	962
	963	! inputs:
	964	INTEGER len, ncum, nd, ntra, nloc
	965	INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len)
	966	REAL plcl1(len), tnk1(len), qnk1(len), gznk1(len)
	967	REAL pbase1(len), buoybase1(len)
	968	REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
	969	REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
	970	REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
	971	REAL tvp1(len, nd), clw1(len, nd)
	972	REAL th1(len, nd)
	973	REAL sig1(len, nd), w01(len, nd)
	974	REAL tra1(len, nd, ntra)
	975	#ifdef ISO
	976	!integer niso
	977	real xt1(ntraciso,len,nd), xtclw1(ntraciso,len,nd)
	978	real xtnk1(ntraciso,len)
	979	#endif
	980
	981	! outputs:
	982	! en fait, on a nloc=len pour l'instant (cf cv_driver)
	983	INTEGER iflag(nloc), nk(nloc), icb(nloc), icbs(nloc)
	984	REAL plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
	985	REAL pbase(nloc), buoybase(nloc)
	986	REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
	987	REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
	988	REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
	989	REAL tvp(nloc, nd), clw(nloc, nd)
	990	REAL th(nloc, nd)
	991	REAL sig(nloc, nd), w0(nloc, nd)
	992	REAL tra(nloc, nd, ntra)
	993	#ifdef ISO
	994	real xt(ntraciso,nloc,nd), xtclw(ntraciso,nloc,nd)
	995	real xtnk(ntraciso,nloc)
	996	#endif
	997
	998	! local variables:
	999	INTEGER i, k, nn, j
	1000	#ifdef ISO
	1001	integer ixt
	1002	#endif
	1003
	1004	CHARACTER (LEN=20) :: modname = 'cv30_compress'
	1005	CHARACTER (LEN=80) :: abort_message
	1006
	1007	#ifdef ISO
	1008	! initialisation des champs compresses:
	1009	do k=1,nd
	1010	do i=1,nloc
	1011	if (essai_convergence) then
	1012	else
	1013	q(i,k)=0.0
[4050]	1014	clw(i,k)=0.0 ! mise en commentaire le 5 avril pour verif
[3927]	1015	! convergence
	1016	endif !f (negation(essai_convergence)) then
	1017	do ixt=1,ntraciso
	1018	xt(ixt,i,k)=0.0
	1019	xtclw(ixt,i,k)=0.0
	1020	enddo !do ixt=1,niso
	1021	enddo !do i=1,len
	1022	enddo !do k=1,nd
	1023	! write(,) 'q(1,1),xt(iso_eau,1,1)=',q(1,1),xt(iso_eau,1,1)
	1024	#endif
	1025
	1026	DO k = 1, nl + 1
	1027	nn = 0
	1028	DO i = 1, len
	1029	IF (iflag1(i)==0) THEN
	1030	nn = nn + 1
	1031	sig(nn, k) = sig1(i, k)
	1032	w0(nn, k) = w01(i, k)
	1033	t(nn, k) = t1(i, k)
	1034	q(nn, k) = q1(i, k)
	1035	qs(nn, k) = qs1(i, k)
	1036	u(nn, k) = u1(i, k)
	1037	v(nn, k) = v1(i, k)
	1038	gz(nn, k) = gz1(i, k)
	1039	h(nn, k) = h1(i, k)
	1040	lv(nn, k) = lv1(i, k)
	1041	cpn(nn, k) = cpn1(i, k)
	1042	p(nn, k) = p1(i, k)
	1043	ph(nn, k) = ph1(i, k)
	1044	tv(nn, k) = tv1(i, k)
	1045	tp(nn, k) = tp1(i, k)
	1046	tvp(nn, k) = tvp1(i, k)
	1047	clw(nn, k) = clw1(i, k)
	1048	th(nn, k) = th1(i, k)
	1049	#ifdef ISO
	1050	do ixt = 1, ntraciso
	1051	xt(ixt,nn,k)=xt1(ixt,i,k)
	1052	xtclw(ixt,nn,k)=xtclw1(ixt,i,k)
	1053	enddo
	1054	! write(,) 'nn,i,k,q(nn,k),xt(iso_eau,nn,k)=', &
	1055	! & nn,i,k,q(nn, k),xt(ixt,nn,k)
	1056	#endif
	1057	END IF
	1058	END DO
	1059	END DO
	1060
	1061	! do 121 j=1,ntra
	1062	! do 111 k=1,nd
	1063	! nn=0
	1064	! do 101 i=1,len
	1065	! if(iflag1(i).eq.0)then
	1066	! nn=nn+1
	1067	! tra(nn,k,j)=tra1(i,k,j)
	1068	! endif
	1069	! 101 continue
	1070	! 111 continue
	1071	! 121 continue
	1072
	1073	IF (nn/=ncum) THEN
	1074	WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
	1075	abort_message = ''
	1076	CALL abort_physic(modname, abort_message, 1)
	1077	END IF
	1078
	1079	nn = 0
	1080	DO i = 1, len
	1081	IF (iflag1(i)==0) THEN
	1082	nn = nn + 1
	1083	pbase(nn) = pbase1(i)
	1084	buoybase(nn) = buoybase1(i)
	1085	plcl(nn) = plcl1(i)
	1086	tnk(nn) = tnk1(i)
	1087	qnk(nn) = qnk1(i)
	1088	gznk(nn) = gznk1(i)
	1089	nk(nn) = nk1(i)
	1090	icb(nn) = icb1(i)
	1091	icbs(nn) = icbs1(i)
	1092	iflag(nn) = iflag1(i)
	1093	#ifdef ISO
	1094	do ixt=1,ntraciso
	1095	xtnk(ixt,nn) = xtnk1(ixt,i)
	1096	enddo
	1097	#endif
	1098	END IF
	1099	END DO
	1100
	1101	#ifdef ISO
	1102	#ifdef ISOVERIF
	1103	if (iso_eau.gt.0) then
	1104	do k = 1, nd
	1105	do i = 1, nloc
	1106	!write(,) 'i,k=',i,k
	1107	call iso_verif_egalite_choix(xtclw(iso_eau,i,k),clw(i,k), &
	1108	& 'compress 973',errmax,errmaxrel)
	1109	call iso_verif_egalite_choix(xt(iso_eau,i,k),q(i,k), &
	1110	& 'compress 975',errmax,errmaxrel)
	1111	enddo
	1112	enddo
	1113	endif !if (iso_eau.gt.0) then
	1114	do k = 1, nd
	1115	do i = 1, nn
	1116	call iso_verif_positif(q(i,k),'compress 1004')
	1117	enddo
	1118	enddo
	1119	#endif
	1120	#endif
	1121
	1122
	1123	RETURN
	1124	END SUBROUTINE cv30_compress
	1125
	1126	SUBROUTINE cv30_undilute2(nloc, ncum, nd, icb, icbs, nk, tnk, qnk, gznk, t, &
	1127	q, qs, gz, p, h, tv, lv, pbase, buoybase, plcl, inb, tp, tvp, clw, hp, &
	1128	ep, sigp, buoy &
	1129	#ifdef ISO
	1130	& ,xtnk,xt,xtclw &
	1131	#endif
	1132	& )
	1133	! epmax_cape: ajout arguments
	1134	#ifdef ISO
[4143]	1135	use infotrac_phy, ONLY: ntraciso=>ntiso
[3927]	1136	USE isotopes_mod, ONLY: pxtmelt,pxtice,pxtmin,pxtmax,cond_temp_env, iso_eau,iso_HDO
	1137	USE isotopes_routines_mod, ONLY: condiso_liq_ice_vectall
	1138	#ifdef ISOTRAC
	1139	USE isotopes_routines_mod, ONLY: condiso_liq_ice_vectall_trac
	1140	#ifdef ISOVERIF
	1141	USE isotopes_verif_mod, ONLY: iso_verif_traceur
	1142	#endif
	1143	#endif
	1144	#ifdef ISOVERIF
	1145	use isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif,Tmax_verif, &
	1146	iso_verif_egalite_choix, iso_verif_noNaN,iso_verif_aberrant, &
	1147	iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
	1148	iso_verif_egalite_nostop,iso_verif_aberrant_nostop,deltaD,iso_verif_noNaN_nostop, &
	1149	iso_verif_positif,iso_verif_egalite_vect2D
	1150	#endif
	1151	#endif
	1152	IMPLICIT NONE
	1153
	1154	! ---------------------------------------------------------------------
	1155	! Purpose:
	1156	! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
	1157	! &
	1158	! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
	1159	! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
	1160	! &
	1161	! FIND THE LEVEL OF NEUTRAL BUOYANCY
	1162
	1163	! Main differences convect3/convect4:
	1164	! - icbs (input) is the first level above LCL (may differ from icb)
	1165	! - many minor differences in the iterations
	1166	! - condensed water not removed from tvp in convect3
	1167	! - vertical profile of buoyancy computed here (use of buoybase)
	1168	! - the determination of inb is different
	1169	! - no inb1, only inb in output
	1170	! ---------------------------------------------------------------------
	1171
	1172	include "cvthermo.h"
	1173	include "cv30param.h"
	1174	include "conema3.h"
	1175
	1176	! inputs:
	1177	INTEGER ncum, nd, nloc
	1178	INTEGER icb(nloc), icbs(nloc), nk(nloc)
	1179	REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
	1180	REAL p(nloc, nd)
	1181	REAL tnk(nloc), qnk(nloc), gznk(nloc)
	1182	REAL lv(nloc, nd), tv(nloc, nd), h(nloc, nd)
	1183	REAL pbase(nloc), buoybase(nloc), plcl(nloc)
	1184
	1185	! outputs:
	1186	INTEGER inb(nloc)
	1187	REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
	1188	REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
	1189	REAL buoy(nloc, nd)
	1190
	1191	! local variables:
	1192	INTEGER i, k
	1193	REAL tg, qg, ahg, alv, s, tc, es, denom, rg, tca, elacrit
	1194	REAL by, defrac, pden
	1195	REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
	1196	LOGICAL lcape(nloc)
	1197
	1198	#ifdef ISO
	1199	real xt(ntraciso,nloc,nd), xtclw(ntraciso,nloc,nd)
	1200	real xtnk(ntraciso,nloc)
	1201	! real xtep(ntraciso,nloc,nd) ! le 7 mai: on supprime xtep, car pas besoin
	1202	! la chute de precip ne fractionne pas.
	1203	integer ixt
	1204	real zfice(nloc),zxtliq(ntraciso,nloc),zxtice(ntraciso,nloc)
	1205	real clw_k(nloc),tg_k(nloc)
	1206	#ifdef ISOVERIF
	1207	real qg_save(nloc,nd) ! inout
	1208	!integer iso_verif_positif_nostop
	1209	#endif
	1210	#endif
	1211
	1212	! =====================================================================
	1213	! --- SOME INITIALIZATIONS
	1214	! =====================================================================
	1215
	1216	DO k = 1, nl
	1217	DO i = 1, ncum
	1218	ep(i, k) = 0.0
	1219	sigp(i, k) = spfac
	1220	clw(i,k)=0.0 ! C Risi
	1221	END DO
	1222	END DO
	1223
	1224	! =====================================================================
	1225	! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
	1226	! =====================================================================
	1227
	1228	! --- The procedure is to solve the equation.
	1229	! cptp+Lqp+phi=cptnk+Lqnk+gznk.
	1230
	1231	! * Calculate certain parcel quantities, including static energy *
	1232
	1233
	1234	DO i = 1, ncum
	1235	ah0(i) = (cpd(1.-qnk(i))+clqnk(i))*tnk(i) & ! debug &
	1236	! +qnk(i)(lv0-clmcpv(tnk(i)-t0))+gznk(i)
	1237	+qnk(i)(lv0-clmcpv(tnk(i)-273.15)) + gznk(i)
	1238	END DO
	1239
	1240
	1241	! * Find lifted parcel quantities above cloud base *
	1242
	1243
	1244	DO k = minorig + 1, nl
	1245	DO i = 1, ncum
	1246	! ori if(k.ge.(icb(i)+1))then
	1247	IF (k>=(icbs(i)+1)) THEN ! convect3
	1248	tg = t(i, k)
	1249	qg = qs(i, k)
	1250	! debug alv=lv0-clmcpv*(t(i,k)-t0)
	1251	alv = lv0 - clmcpv*(t(i,k)-273.15)
	1252
	1253	! First iteration.
	1254
	1255	! ori s=cpd+alvalvqg/(rrvt(i,k)t(i,k))
	1256	s = cpd(1.-qnk(i)) + clqnk(i) & ! convect3
	1257	+alvalvqg/(rrvt(i,k)t(i,k)) ! convect3
	1258	s = 1./s
	1259	! ori ahg=cpdtg+(cl-cpd)qnk(i)t(i,k)+alvqg+gz(i,k)
	1260	ahg = cpdtg + (cl-cpd)qnk(i)tg + alvqg + gz(i, k) ! convect3
	1261	tg = tg + s*(ah0(i)-ahg)
	1262	! ori tg=max(tg,35.0)
	1263	! debug tc=tg-t0
	1264	tc = tg - 273.15
	1265	denom = 243.5 + tc
	1266	denom = max(denom, 1.0) ! convect3
	1267	! ori if(tc.ge.0.0)then
	1268	es = 6.112exp(17.67tc/denom)
	1269	! ori else
	1270	! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
	1271	! ori endif
	1272	qg = epses/(p(i,k)-es(1.-eps))
	1273	! qg=max(0.0,qg) ! C Risi
	1274
	1275	! Second iteration.
	1276
	1277	! ori s=cpd+alvalvqg/(rrvt(i,k)t(i,k))
	1278	! ori s=1./s
	1279	! ori ahg=cpdtg+(cl-cpd)qnk(i)t(i,k)+alvqg+gz(i,k)
	1280	ahg = cpdtg + (cl-cpd)qnk(i)tg + alvqg + gz(i, k) ! convect3
	1281	tg = tg + s*(ah0(i)-ahg)
	1282	! ori tg=max(tg,35.0)
	1283	! debug tc=tg-t0
	1284	tc = tg - 273.15
	1285	denom = 243.5 + tc
	1286	denom = max(denom, 1.0) ! convect3
	1287	! ori if(tc.ge.0.0)then
	1288	es = 6.112exp(17.67tc/denom)
	1289	! ori else
	1290	! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
	1291	! ori endif
	1292	qg = epses/(p(i,k)-es(1.-eps))
	1293	! qg=max(0.0,qg) ! C Risi
	1294
	1295	! debug alv=lv0-clmcpv*(t(i,k)-t0)
	1296	alv = lv0 - clmcpv*(t(i,k)-273.15)
	1297	! print*,'cpd dans convect2 ',cpd
	1298	! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
	1299	! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
	1300
	1301	! ori c approximation here:
	1302	! ori
	1303	! tp(i,k)=(ah0(i)-(cl-cpd)qnk(i)t(i,k)-gz(i,k)-alv*qg)/cpd
	1304
	1305	! convect3: no approximation:
	1306	tp(i, k) = (ah0(i)-gz(i,k)-alvqg)/(cpd+(cl-cpd)qnk(i))
	1307
	1308	clw(i, k) = qnk(i) - qg
	1309	clw(i, k) = max(0.0, clw(i,k))
	1310	rg = qg/(1.-qnk(i))
	1311	! ori tvp(i,k)=tp(i,k)(1.+rgepsi)
	1312	! convect3: (qg utilise au lieu du vrai mixing ratio rg):
	1313	tvp(i, k) = tp(i, k)*(1.+qg/eps-qnk(i)) ! whole thing
	1314
	1315	END IF
	1316	END DO
	1317	#ifdef ISO
	1318	! calcul de zfice
	1319	do i=1,ncum
	1320	zfice(i) = 1.0-(t(i,k)-pxtice)/(pxtmelt-pxtice)
	1321	zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
	1322	enddo
	1323	do i=1,ncum
	1324	clw_k(i)=clw(i,k)
	1325	tg_k(i)=t(i,k)
	1326	enddo !do i=1,ncum
	1327	#ifdef ISOVERIF
	1328	!write(,) 'cv30_routine 1259: avant condiso'
	1329	if (iso_HDO.gt.0) then
	1330	do i=1,ncum
	1331	call iso_verif_aberrant(xtnk(iso_hdo,i)/qnk(i), &
	1332	& 'cv30_routines 1231')
	1333	enddo
	1334	endif !if (iso_HDO.gt.0) then
	1335	if (iso_eau.gt.0) then
	1336	do i=1,ncum
	1337	call iso_verif_egalite(xtnk(iso_eau,i),qnk(i), &
	1338	& 'cv30_routines 1373')
	1339	enddo
	1340	endif !if (iso_HDO.gt.0) then
	1341	do i=1,ncum
	1342	if ((iso_verif_positif_nostop(qnk(i)-clw_k(i), &
	1343	& 'cv30_routines 1275').eq.1).or. &
	1344	& (iso_verif_positif_nostop(tg_k(i)-Tmin_verif, &
	1345	& 'cv30_routines 1297a').eq.1).or. &
	1346	& (iso_verif_positif_nostop(Tmax_verif-tg_k(i), &
	1347	& 'cv30_routines 1297b').eq.1)) then
	1348	write(,) 'i,k,qnk,clw_k=',i,k,qnk(i),clw_k(i)
	1349	write(,) 'tg,t,qg=',tg_k(i),t(i,k),qg_save(i,k)
	1350	write(,) 'icbs(i)=',icbs(i)
	1351	stop
	1352	endif ! if ((iso_verif_positif_nostop
	1353	enddo !do i=1,ncum
	1354	#ifdef ISOTRAC
	1355	do i=1,ncum
	1356	call iso_verif_traceur(xtnk(1,i),'cv30_routines 1251')
	1357	enddo !do i=1,ncum
	1358	#endif
	1359	#endif
	1360	call condiso_liq_ice_vectall(xtnk(1,1),qnk(1), &
	1361	& clw_k(1),tg_k(1), &
	1362	& zfice(1),zxtice(1,1),zxtliq(1,1),ncum)
	1363	#ifdef ISOTRAC
	1364	#ifdef ISOVERIF
	1365	write(,) 'cv30_routines 1283: condiso pour traceurs'
	1366	#endif
	1367	call condiso_liq_ice_vectall_trac(xtnk(1,1),qnk(1), &
	1368	& clw_k(1),tg_k(1), &
	1369	& zfice(1),zxtice(1,1),zxtliq(1,1),ncum)
	1370	#endif
	1371	do i=1,ncum
	1372	do ixt=1,ntraciso
	1373	xtclw(ixt,i,k)=zxtice(ixt,i)+zxtliq(ixt,i)
	1374	xtclw(ixt,i,k)=max(0.0,xtclw(ixt,i,k))
	1375	enddo !do ixt=1,niso
	1376	enddo !do i=1,ncum
	1377	#ifdef ISOVERIF
	1378	if (iso_eau.gt.0) then
	1379	do i=1,ncum
	1380	call iso_verif_egalite_choix(xtclw(iso_eau,i,k), &
	1381	& clw(i,k),'cv30_routines 1223',errmax,errmaxrel)
	1382	enddo
	1383	endif !if (iso_eau.gt.0) then
	1384	#ifdef ISOTRAC
	1385	do i=1,ncum
	1386	call iso_verif_traceur(xtclw(1,i,k),'cv30_routines 1275')
	1387	enddo
	1388	#endif
	1389	#endif
	1390	#endif
	1391	END DO
	1392
	1393	! =====================================================================
	1394	! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
	1395	! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
	1396	! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
	1397	! =====================================================================
	1398
	1399	! ori do 320 k=minorig+1,nl
	1400	DO k = 1, nl ! convect3
	1401	DO i = 1, ncum
	1402	pden = ptcrit - pbcrit
	1403	ep(i, k) = (plcl(i)-p(i,k)-pbcrit)/pden*epmax
	1404	ep(i, k) = amax1(ep(i,k), 0.0)
	1405	ep(i, k) = amin1(ep(i,k), epmax)
	1406	sigp(i, k) = spfac
	1407	! ori if(k.ge.(nk(i)+1))then
	1408	! ori tca=tp(i,k)-t0
	1409	! ori if(tca.ge.0.0)then
	1410	! ori elacrit=elcrit
	1411	! ori else
	1412	! ori elacrit=elcrit*(1.0-tca/tlcrit)
	1413	! ori endif
	1414	! ori elacrit=max(elacrit,0.0)
	1415	! ori ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
	1416	! ori ep(i,k)=max(ep(i,k),0.0 )
	1417	! ori ep(i,k)=min(ep(i,k),1.0 )
	1418	! ori sigp(i,k)=sigs
	1419	! ori endif
	1420	END DO
	1421	END DO
	1422
	1423	! =====================================================================
	1424	! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
	1425	! --- VIRTUAL TEMPERATURE
	1426	! =====================================================================
	1427
	1428	! dans convect3, tvp est calcule en une seule fois, et sans retirer
	1429	! l'eau condensee (~> reversible CAPE)
	1430
	1431	! ori do 340 k=minorig+1,nl
	1432	! ori do 330 i=1,ncum
	1433	! ori if(k.ge.(icb(i)+1))then
	1434	! ori tvp(i,k)=tvp(i,k)(1.0-qnk(i)+ep(i,k)clw(i,k))
	1435	! oric print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
	1436	! oric print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
	1437	! ori endif
	1438	! ori 330 continue
	1439	! ori 340 continue
	1440
	1441	! ori do 350 i=1,ncum
	1442	! ori tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
	1443	! ori 350 continue
	1444
	1445	DO i = 1, ncum ! convect3
	1446	tp(i, nlp) = tp(i, nl) ! convect3
	1447	END DO ! convect3
	1448
	1449	! =====================================================================
	1450	! --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
	1451	! =====================================================================
	1452
	1453	! -- this is for convect3 only:
	1454
	1455	! first estimate of buoyancy:
	1456
	1457	DO i = 1, ncum
	1458	DO k = 1, nl
	1459	buoy(i, k) = tvp(i, k) - tv(i, k)
	1460	END DO
	1461	END DO
	1462
	1463	! set buoyancy=buoybase for all levels below base
	1464	! for safety, set buoy(icb)=buoybase
	1465
	1466	DO i = 1, ncum
	1467	DO k = 1, nl
	1468	IF ((k>=icb(i)) .AND. (k<=nl) .AND. (p(i,k)>=pbase(i))) THEN
	1469	buoy(i, k) = buoybase(i)
	1470	END IF
	1471	END DO
	1472	! IM cf. CRio/JYG 270807 buoy(icb(i),k)=buoybase(i)
	1473	buoy(i, icb(i)) = buoybase(i)
	1474	END DO
	1475
	1476	! -- end convect3
	1477
	1478	! =====================================================================
	1479	! --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
	1480	! --- LEVEL OF NEUTRAL BUOYANCY
	1481	! =====================================================================
	1482
	1483	! -- this is for convect3 only:
	1484
	1485	DO i = 1, ncum
	1486	inb(i) = nl - 1
	1487	END DO
	1488
	1489	DO i = 1, ncum
	1490	DO k = 1, nl - 1
	1491	IF ((k>=icb(i)) .AND. (buoy(i,k)<dtovsh)) THEN
	1492	inb(i) = min(inb(i), k)
	1493	END IF
	1494	END DO
	1495	END DO
	1496
	1497	! -- end convect3
	1498
	1499	! ori do 510 i=1,ncum
	1500	! ori cape(i)=0.0
	1501	! ori capem(i)=0.0
	1502	! ori inb(i)=icb(i)+1
	1503	! ori inb1(i)=inb(i)
	1504	! ori 510 continue
	1505
	1506	! Originial Code
	1507
	1508	! do 530 k=minorig+1,nl-1
	1509	! do 520 i=1,ncum
	1510	! if(k.ge.(icb(i)+1))then
	1511	! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
	1512	! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
	1513	! cape(i)=cape(i)+by
	1514	! if(by.ge.0.0)inb1(i)=k+1
	1515	! if(cape(i).gt.0.0)then
	1516	! inb(i)=k+1
	1517	! capem(i)=cape(i)
	1518	! endif
	1519	! endif
	1520	! 520 continue
	1521	! 530 continue
	1522	! do 540 i=1,ncum
	1523	! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
	1524	! cape(i)=capem(i)+byp
	1525	! defrac=capem(i)-cape(i)
	1526	! defrac=max(defrac,0.001)
	1527	! frac(i)=-cape(i)/defrac
	1528	! frac(i)=min(frac(i),1.0)
	1529	! frac(i)=max(frac(i),0.0)
	1530	! 540 continue
	1531
	1532	! K Emanuel fix
	1533
	1534	! call zilch(byp,ncum)
	1535	! do 530 k=minorig+1,nl-1
	1536	! do 520 i=1,ncum
	1537	! if(k.ge.(icb(i)+1))then
	1538	! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
	1539	! cape(i)=cape(i)+by
	1540	! if(by.ge.0.0)inb1(i)=k+1
	1541	! if(cape(i).gt.0.0)then
	1542	! inb(i)=k+1
	1543	! capem(i)=cape(i)
	1544	! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
	1545	! endif
	1546	! endif
	1547	! 520 continue
	1548	! 530 continue
	1549	! do 540 i=1,ncum
	1550	! inb(i)=max(inb(i),inb1(i))
	1551	! cape(i)=capem(i)+byp(i)
	1552	! defrac=capem(i)-cape(i)
	1553	! defrac=max(defrac,0.001)
	1554	! frac(i)=-cape(i)/defrac
	1555	! frac(i)=min(frac(i),1.0)
	1556	! frac(i)=max(frac(i),0.0)
	1557	! 540 continue
	1558
	1559	! J Teixeira fix
	1560
	1561	! ori call zilch(byp,ncum)
	1562	! ori do 515 i=1,ncum
	1563	! ori lcape(i)=.true.
	1564	! ori 515 continue
	1565	! ori do 530 k=minorig+1,nl-1
	1566	! ori do 520 i=1,ncum
	1567	! ori if(cape(i).lt.0.0)lcape(i)=.false.
	1568	! ori if((k.ge.(icb(i)+1)).and.lcape(i))then
	1569	! ori by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
	1570	! ori byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
	1571	! ori cape(i)=cape(i)+by
	1572	! ori if(by.ge.0.0)inb1(i)=k+1
	1573	! ori if(cape(i).gt.0.0)then
	1574	! ori inb(i)=k+1
	1575	! ori capem(i)=cape(i)
	1576	! ori endif
	1577	! ori endif
	1578	! ori 520 continue
	1579	! ori 530 continue
	1580	! ori do 540 i=1,ncum
	1581	! ori cape(i)=capem(i)+byp(i)
	1582	! ori defrac=capem(i)-cape(i)
	1583	! ori defrac=max(defrac,0.001)
	1584	! ori frac(i)=-cape(i)/defrac
	1585	! ori frac(i)=min(frac(i),1.0)
	1586	! ori frac(i)=max(frac(i),0.0)
	1587	! ori 540 continue
	1588
	1589	! =====================================================================
	1590	! --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
	1591	! =====================================================================
	1592
	1593	! ym do i=1,ncum*nlp
	1594	! ym hp(i,1)=h(i,1)
	1595	! ym enddo
	1596
	1597	DO k = 1, nlp
	1598	DO i = 1, ncum
	1599	hp(i, k) = h(i, k)
	1600	END DO
	1601	END DO
	1602
	1603	DO k = minorig + 1, nl
	1604	DO i = 1, ncum
	1605	IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
	1606	hp(i, k) = h(i, nk(i)) + (lv(i,k)+(cpd-cpv)t(i,k))ep(i, k)*clw(i, k &
	1607	)
	1608	END IF
	1609	END DO
	1610	END DO
	1611
	1612	RETURN
	1613	END SUBROUTINE cv30_undilute2
	1614
	1615	SUBROUTINE cv30_closure(nloc, ncum, nd, icb, inb, pbase, p, ph, tv, buoy, &
	1616	sig, w0, cape, m)
	1617	IMPLICIT NONE
	1618
	1619	! ===================================================================
	1620	! --- CLOSURE OF CONVECT3
	1621
	1622	! vectorization: S. Bony
	1623	! ===================================================================
	1624
	1625	include "cvthermo.h"
	1626	include "cv30param.h"
	1627
	1628	! input:
	1629	INTEGER ncum, nd, nloc
	1630	INTEGER icb(nloc), inb(nloc)
	1631	REAL pbase(nloc)
	1632	REAL p(nloc, nd), ph(nloc, nd+1)
	1633	REAL tv(nloc, nd), buoy(nloc, nd)
	1634
	1635	! input/output:
	1636	REAL sig(nloc, nd), w0(nloc, nd)
	1637
	1638	! output:
	1639	REAL cape(nloc)
	1640	REAL m(nloc, nd)
	1641
	1642	! local variables:
	1643	INTEGER i, j, k, icbmax
	1644	REAL deltap, fac, w, amu
	1645	REAL dtmin(nloc, nd), sigold(nloc, nd)
	1646
	1647	! -------------------------------------------------------
	1648	! -- Initialization
	1649	! -------------------------------------------------------
	1650
	1651	DO k = 1, nl
	1652	DO i = 1, ncum
	1653	m(i, k) = 0.0
	1654	END DO
	1655	END DO
	1656
	1657	! -------------------------------------------------------
	1658	! -- Reset sig(i) and w0(i) for i>inb and i<icb
	1659	! -------------------------------------------------------
	1660
	1661	! update sig and w0 above LNB:
	1662
	1663	DO k = 1, nl - 1
	1664	DO i = 1, ncum
	1665	IF ((inb(i)<(nl-1)) .AND. (k>=(inb(i)+1))) THEN
	1666	sig(i, k) = betasig(i, k) + 2.alphabuoy(i, inb(i))abs(buoy(i,inb( &
	1667	i)))
	1668	sig(i, k) = amax1(sig(i,k), 0.0)
	1669	w0(i, k) = beta*w0(i, k)
	1670	END IF
	1671	END DO
	1672	END DO
	1673
	1674	! compute icbmax:
	1675
	1676	icbmax = 2
	1677	DO i = 1, ncum
	1678	icbmax = max(icbmax, icb(i))
	1679	END DO
	1680
	1681	! update sig and w0 below cloud base:
	1682
	1683	DO k = 1, icbmax
	1684	DO i = 1, ncum
	1685	IF (k<=icb(i)) THEN
	1686	sig(i, k) = betasig(i, k) - 2.alphabuoy(i, icb(i))buoy(i, icb(i))
	1687	sig(i, k) = amax1(sig(i,k), 0.0)
	1688	w0(i, k) = beta*w0(i, k)
	1689	END IF
	1690	END DO
	1691	END DO
	1692
	1693	! ! if(inb.lt.(nl-1))then
	1694	! ! do 85 i=inb+1,nl-1
	1695	! ! sig(i)=betasig(i)+2.alphabuoy(inb)
	1696	! ! 1 abs(buoy(inb))
	1697	! ! sig(i)=amax1(sig(i),0.0)
	1698	! ! w0(i)=beta*w0(i)
	1699	! ! 85 continue
	1700	! ! end if
	1701
	1702	! ! do 87 i=1,icb
	1703	! ! sig(i)=betasig(i)-2.alphabuoy(icb)buoy(icb)
	1704	! ! sig(i)=amax1(sig(i),0.0)
	1705	! ! w0(i)=beta*w0(i)
	1706	! ! 87 continue
	1707
	1708	! -------------------------------------------------------------
	1709	! -- Reset fractional areas of updrafts and w0 at initial time
	1710	! -- and after 10 time steps of no convection
	1711	! -------------------------------------------------------------
	1712
	1713	DO k = 1, nl - 1
	1714	DO i = 1, ncum
	1715	IF (sig(i,nd)<1.5 .OR. sig(i,nd)>12.0) THEN
	1716	sig(i, k) = 0.0
	1717	w0(i, k) = 0.0
	1718	END IF
	1719	END DO
	1720	END DO
	1721
	1722	! -------------------------------------------------------------
	1723	! -- Calculate convective available potential energy (cape),
	1724	! -- vertical velocity (w), fractional area covered by
	1725	! -- undilute updraft (sig), and updraft mass flux (m)
	1726	! -------------------------------------------------------------
	1727
	1728	DO i = 1, ncum
	1729	cape(i) = 0.0
	1730	END DO
	1731
	1732	! compute dtmin (minimum buoyancy between ICB and given level k):
	1733
	1734	DO i = 1, ncum
	1735	DO k = 1, nl
	1736	dtmin(i, k) = 100.0
	1737	END DO
	1738	END DO
	1739
	1740	DO i = 1, ncum
	1741	DO k = 1, nl
	1742	DO j = minorig, nl
	1743	IF ((k>=(icb(i)+1)) .AND. (k<=inb(i)) .AND. (j>=icb(i)) .AND. (j<=(k- &
	1744	1))) THEN
	1745	dtmin(i, k) = amin1(dtmin(i,k), buoy(i,j))
	1746	END IF
	1747	END DO
	1748	END DO
	1749	END DO
	1750
	1751	! the interval on which cape is computed starts at pbase :
	1752	DO k = 1, nl
	1753	DO i = 1, ncum
	1754
	1755	IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
	1756
	1757	deltap = min(pbase(i), ph(i,k-1)) - min(pbase(i), ph(i,k))
	1758	cape(i) = cape(i) + rrdbuoy(i, k-1)deltap/p(i, k-1)
	1759	cape(i) = amax1(0.0, cape(i))
	1760	sigold(i, k) = sig(i, k)
	1761
	1762	! dtmin(i,k)=100.0
	1763	! do 97 j=icb(i),k-1 ! mauvaise vectorisation
	1764	! dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
	1765	! 97 continue
	1766
	1767	sig(i, k) = betasig(i, k) + alphadtmin(i, k)*abs(dtmin(i,k))
	1768	sig(i, k) = amax1(sig(i,k), 0.0)
	1769	sig(i, k) = amin1(sig(i,k), 0.01)
	1770	fac = amin1(((dtcrit-dtmin(i,k))/dtcrit), 1.0)
	1771	w = (1.-beta)facsqrt(cape(i)) + beta*w0(i, k)
	1772	amu = 0.5(sig(i,k)+sigold(i,k))w
	1773	m(i, k) = amu0.007p(i, k)*(ph(i,k)-ph(i,k+1))/tv(i, k)
	1774	w0(i, k) = w
	1775	END IF
	1776
	1777	END DO
	1778	END DO
	1779
	1780	DO i = 1, ncum
	1781	w0(i, icb(i)) = 0.5*w0(i, icb(i)+1)
	1782	m(i, icb(i)) = 0.5m(i, icb(i)+1)(ph(i,icb(i))-ph(i,icb(i)+1))/ &
	1783	(ph(i,icb(i)+1)-ph(i,icb(i)+2))
	1784	sig(i, icb(i)) = sig(i, icb(i)+1)
	1785	sig(i, icb(i)-1) = sig(i, icb(i))
	1786	END DO
	1787
	1788
	1789	! ! cape=0.0
	1790	! ! do 98 i=icb+1,inb
	1791	! ! deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
	1792	! ! cape=cape+rrdbuoy(i-1)deltap/p(i-1)
	1793	! ! dcape=rrdbuoy(i-1)deltap/p(i-1)
	1794	! ! dlnp=deltap/p(i-1)
	1795	! ! cape=amax1(0.0,cape)
	1796	! ! sigold=sig(i)
	1797
	1798	! ! dtmin=100.0
	1799	! ! do 97 j=icb,i-1
	1800	! ! dtmin=amin1(dtmin,buoy(j))
	1801	! ! 97 continue
	1802
	1803	! ! sig(i)=betasig(i)+alphadtmin*abs(dtmin)
	1804	! ! sig(i)=amax1(sig(i),0.0)
	1805	! ! sig(i)=amin1(sig(i),0.01)
	1806	! ! fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
	1807	! ! w=(1.-beta)facsqrt(cape)+beta*w0(i)
	1808	! ! amu=0.5(sig(i)+sigold)w
	1809	! ! m(i)=amu0.007p(i)*(ph(i)-ph(i+1))/tv(i)
	1810	! ! w0(i)=w
	1811	! ! 98 continue
	1812	! ! w0(icb)=0.5*w0(icb+1)
	1813	! ! m(icb)=0.5m(icb+1)(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
	1814	! ! sig(icb)=sig(icb+1)
	1815	! ! sig(icb-1)=sig(icb)
	1816
	1817	RETURN
	1818	END SUBROUTINE cv30_closure
	1819
	1820	SUBROUTINE cv30_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, ph, t, rr, rs, &
	1821	u, v, tra, h, lv, qnk, hp, tv, tvp, ep, clw, m, sig, ment, qent, uent, &
	1822	vent, sij, elij, ments, qents, traent &
	1823	#ifdef ISO
	1824	& ,xt,xtnk,xtclw &
	1825	& ,xtent,xtelij &
	1826	#endif
	1827	& )
	1828
	1829	#ifdef ISO
[4143]	1830	use infotrac_phy, ONLY: ntraciso=>ntiso,niso,itZonIso
[3927]	1831	USE isotopes_mod, ONLY: pxtmelt,pxtice,pxtmin,pxtmax, iso_eau,iso_HDO, &
	1832	ridicule
	1833	USE isotopes_routines_mod, ONLY: condiso_liq_ice_vectall
	1834	#ifdef ISOVERIF
	1835	use isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif,deltalim, &
	1836	iso_verif_egalite_choix,iso_verif_aberrant_choix, iso_verif_noNaN, &
	1837	iso_verif_aberrant, &
	1838	iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
	1839	iso_verif_egalite_nostop,iso_verif_aberrant_nostop,deltaD,iso_verif_noNaN_nostop, &
	1840	iso_verif_positif,iso_verif_egalite_vect2D
	1841	#endif
	1842	#ifdef ISOTRAC
	1843	use isotrac_mod, only: option_tmin,option_traceurs,seuil_tag_tmin, &
	1844	& option_cond,index_zone,izone_cond,index_iso
	1845	use isotrac_routines_mod, only: iso_recolorise_condensation
	1846	use isotopes_routines_mod, only: condiso_liq_ice_vectall_trac
	1847	#ifdef ISOVERIF
	1848	use isotopes_verif_mod, ONLY: iso_verif_trac17_q_deltad,iso_verif_traceur, &
	1849	& iso_verif_traceur_justmass
	1850	#endif
	1851	#endif
	1852	#endif
	1853	IMPLICIT NONE
	1854
	1855	! ---------------------------------------------------------------------
	1856	! a faire:
	1857	! - changer rr(il,1) -> qnk(il)
	1858	! - vectorisation de la partie normalisation des flux (do 789...)
	1859	! ---------------------------------------------------------------------
	1860
	1861	include "cvthermo.h"
	1862	include "cv30param.h"
	1863
	1864	! inputs:
	1865	INTEGER ncum, nd, na, ntra, nloc
	1866	INTEGER icb(nloc), inb(nloc), nk(nloc)
	1867	REAL sig(nloc, nd)
	1868	REAL qnk(nloc)
	1869	REAL ph(nloc, nd+1)
	1870	REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
	1871	REAL u(nloc, nd), v(nloc, nd)
	1872	REAL tra(nloc, nd, ntra) ! input of convect3
	1873	REAL lv(nloc, na), h(nloc, na), hp(nloc, na)
	1874	REAL tv(nloc, na), tvp(nloc, na), ep(nloc, na), clw(nloc, na)
	1875	REAL m(nloc, na) ! input of convect3
	1876	#ifdef ISO
	1877	real xt(ntraciso,nloc,na), xtclw(ntraciso,nloc,na)
	1878	real tg_save(nloc,nd)
	1879	real xtnk(ntraciso,nloc)
	1880	! real xtep(ntraciso,nloc,na)
	1881	#endif
	1882
	1883	! outputs:
	1884	REAL ment(nloc, na, na), qent(nloc, na, na)
	1885	REAL uent(nloc, na, na), vent(nloc, na, na)
	1886	REAL sij(nloc, na, na), elij(nloc, na, na)
	1887	REAL traent(nloc, nd, nd, ntra)
	1888	REAL ments(nloc, nd, nd), qents(nloc, nd, nd)
	1889	REAL sigij(nloc, nd, nd)
	1890	#ifdef ISO
	1891	real xtent(ntraciso,nloc,nd,nd)
	1892	real xtelij(ntraciso,nloc,nd,nd)
	1893	#endif
	1894
	1895	! local variables:
	1896	INTEGER i, j, k, il, im, jm
	1897	INTEGER num1, num2
	1898	INTEGER nent(nloc, na)
	1899	REAL rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
	1900	REAL alt, smid, sjmin, sjmax, delp, delm
	1901	REAL asij(nloc), smax(nloc), scrit(nloc)
	1902	REAL asum(nloc, nd), bsum(nloc, nd), csum(nloc, nd)
	1903	REAL wgh
	1904	REAL zm(nloc, na)
	1905	LOGICAL lwork(nloc)
	1906	#ifdef ISO
	1907	integer ixt
	1908	real xtrti(ntraciso,nloc)
	1909	real xtres(ntraciso)
[4050]	1910	! on ajoute la dimension nloc a xtrti pour verifs dans les tags: 5 fev
[3927]	1911	! 2010
	1912	real zfice(nloc),zxtliq(ntraciso,nloc),zxtice(ntraciso,nloc)
	1913	! real xt_reduit(ntraciso)
	1914	! logical negation
	1915	!#ifdef ISOVERIF
	1916	! integer iso_verif_positif_nostop
	1917	!#endif
	1918	#endif
	1919
	1920	! =====================================================================
	1921	! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
	1922	! =====================================================================
	1923	#ifdef ISO
	1924	#ifdef ISOVERIF
[4050]	1925	write(,) 'cv30_routines 1820: entree dans cv3_mixing'
[3927]	1926	if (iso_eau.gt.0) then
	1927	call iso_verif_egalite_vect2D( &
	1928	& xtclw,clw, &
	1929	& 'cv30_mixing 1841',ntraciso,nloc,na)
	1930	endif
	1931	#endif
	1932	#endif
	1933
	1934	! ori do 360 i=1,ncum*nlp
	1935	DO j = 1, nl
	1936	DO i = 1, ncum
	1937	nent(i, j) = 0
	1938	! in convect3, m is computed in cv3_closure
	1939	! ori m(i,1)=0.0
	1940	END DO
	1941	END DO
	1942
	1943	! ori do 400 k=1,nlp
	1944	! ori do 390 j=1,nlp
	1945	DO j = 1, nl
	1946	DO k = 1, nl
	1947	DO i = 1, ncum
	1948	qent(i, k, j) = rr(i, j)
	1949	uent(i, k, j) = u(i, j)
	1950	vent(i, k, j) = v(i, j)
	1951	elij(i, k, j) = 0.0
	1952	! ym ment(i,k,j)=0.0
	1953	! ym sij(i,k,j)=0.0
	1954	END DO
	1955	END DO
	1956	END DO
	1957
	1958
	1959	#ifdef ISO
	1960	do j=1,nd
	1961	do k=1,nd
	1962	do i=1,ncum
	1963	do ixt =1,ntraciso
	1964	xtent(ixt,i,k,j)=xt(ixt,i,j)
	1965	xtelij(ixt,i,k,j)=0.0
	1966	enddo !do ixt =1,niso
[4050]	1967	! on initialise mieux que ca qent et elij, meme si au final les
	1968	! valeurs en nd=nl+1 ne sont pas utilisees
[3927]	1969	qent(i,k,j)=rr(i,j)
	1970	elij(i,k,j)=0.0
	1971	enddo !do i=1,ncum
	1972	enddo !do k=1,nl
	1973	enddo !do j=1,nl
	1974	#endif
	1975
	1976	! ym
	1977	ment(1:ncum, 1:nd, 1:nd) = 0.0
	1978	sij(1:ncum, 1:nd, 1:nd) = 0.0
	1979
	1980	! do k=1,ntra
	1981	! do j=1,nd ! instead nlp
	1982	! do i=1,nd ! instead nlp
	1983	! do il=1,ncum
	1984	! traent(il,i,j,k)=tra(il,j,k)
	1985	! enddo
	1986	! enddo
	1987	! enddo
	1988	! enddo
	1989	zm(:, :) = 0.
	1990
	1991	! =====================================================================
	1992	! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
	1993	! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
	1994	! --- FRACTION (sij)
	1995	! =====================================================================
	1996
	1997	DO i = minorig + 1, nl
	1998
	1999	DO j = minorig, nl
	2000	DO il = 1, ncum
	2001	IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)- &
	2002	1)) .AND. (j<=inb(il))) THEN
	2003
	2004	rti = rr(il, 1) - ep(il, i)*clw(il, i)
	2005	bf2 = 1. + lv(il, j)lv(il, j)rs(il, j)/(rrvt(il,j)t(il,j)*cpd)
	2006	anum = h(il, j) - hp(il, i) + (cpv-cpd)t(il, j)(rti-rr(il,j))
	2007	denom = h(il, i) - hp(il, i) + (cpd-cpv)(rr(il,i)-rti)t(il, j)
	2008	dei = denom
	2009	IF (abs(dei)<0.01) dei = 0.01
	2010	sij(il, i, j) = anum/dei
	2011	sij(il, i, i) = 1.0
	2012	altem = sij(il, i, j)rr(il, i) + (1.-sij(il,i,j))rti - rs(il, j)
	2013	altem = altem/bf2
	2014	cwat = clw(il, j)*(1.-ep(il,j))
	2015	stemp = sij(il, i, j)
	2016	IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
	2017	anum = anum - lv(il, j)(rti-rs(il,j)-cwatbf2)
	2018	denom = denom + lv(il, j)*(rr(il,i)-rti)
	2019	IF (abs(denom)<0.01) denom = 0.01
	2020	sij(il, i, j) = anum/denom
	2021	altem = sij(il, i, j)rr(il, i) + (1.-sij(il,i,j))rti - &
	2022	rs(il, j)
	2023	altem = altem - (bf2-1.)*cwat
	2024	END IF
	2025	IF (sij(il,i,j)>0.0 .AND. sij(il,i,j)<0.95) THEN
	2026	qent(il, i, j) = sij(il, i, j)rr(il, i) + (1.-sij(il,i,j))rti
	2027	uent(il, i, j) = sij(il, i, j)*u(il, i) + &
	2028	(1.-sij(il,i,j))*u(il, nk(il))
	2029	vent(il, i, j) = sij(il, i, j)*v(il, i) + &
	2030	(1.-sij(il,i,j))*v(il, nk(il))
	2031	! !!! do k=1,ntra
	2032	! !!! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
	2033	! !!! : +(1.-sij(il,i,j))*tra(il,nk(il),k)
	2034	! !!! end do
	2035	elij(il, i, j) = altem
	2036	elij(il, i, j) = amax1(0.0, elij(il,i,j))
	2037	ment(il, i, j) = m(il, i)/(1.-sij(il,i,j))
	2038	nent(il, i) = nent(il, i) + 1
	2039	END IF
	2040	sij(il, i, j) = amax1(0.0, sij(il,i,j))
	2041	sij(il, i, j) = amin1(1.0, sij(il,i,j))
	2042	END IF ! new
	2043	END DO
	2044
	2045
	2046	#ifdef ISO
	2047	#ifdef ISOVERIF
	2048	!write(,) 'cv30_routines tmp 2078'
	2049	#endif
	2050	do il=1,ncum
	2051	zfice(il) = 1.0-(t(il,j)-pxtice)/(pxtmelt-pxtice)
	2052	zfice(il) = MIN(MAX(zfice(il),0.0),1.0)
	2053	if( (i.ge.icb(il)).and.(i.le.inb(il)).and. &
	2054	& (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
	2055	do ixt=1,ntraciso
	2056	! xtrti(ixt)=xt(ixt,il,1)-xtep(ixt,il,i)*xtclw(ixt,il,i) ! le 7 mai: on supprime xtep
	2057	xtrti(ixt,il)=xt(ixt,il,1)-ep(il,i)*xtclw(ixt,il,i)
	2058	enddo
	2059	if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
	2060	! temperature of condensation (within mixtures):
	2061	! tcond(il)=t(il,j)
	2062	! : + ( sij(il,i,j)rr(il,i)+(1.-sij(il,i,j))rti
	2063	! : - elij(il,i,j) - rs(il,j) )
	2064	! : / ( cpd*(bf2-1.0)/lv(il,j) )
	2065
	2066	do ixt = 1, ntraciso
	2067	! total mixing ratio in the mixtures before precipitation:
	2068	xtent(ixt,il,i,j)=sij(il,i,j)*xt(ixt,il,i) &
	2069	& +(1.-sij(il,i,j))*xtrti(ixt,il)
	2070	enddo !do ixt = 1, ntraciso
	2071	endif !if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
	2072	endif !if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
	2073	enddo !do il=1,ncum
	2074
	2075	call condiso_liq_ice_vectall(xtent(1,1,i,j),qent(1,i,j), &
	2076	& elij(1,i,j), &
	2077	& t(1,j),zfice(1),zxtice(1,1),zxtliq(1,1),ncum)
	2078	#ifdef ISOTRAC
	2079	call condiso_liq_ice_vectall_trac(xtent(1,1,i,j),qent(1,i,j), &
	2080	& elij(1,i,j), &
	2081	& t(1,j),zfice(1),zxtice(1,1),zxtliq(1,1),ncum)
	2082	#ifdef ISOVERIF
	2083	do il=1,ncum
	2084	call iso_verif_traceur(xt(1,il,i),'cv30_routines 1967')
	2085	if( (i.ge.icb(il)).and.(i.le.inb(il)).and. &
	2086	& (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
	2087	call iso_verif_traceur(xtrti(1,il),'cv30_routines 1968')
	2088	endif !if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
	2089	call iso_verif_traceur(xtent(1,il,i,j),'cv30_routines 1969')
	2090
	2091	enddo !do il=1,ncum
	2092	#endif
	2093	#endif
	2094	do il=1,ncum
	2095	do ixt = 1, ntraciso
	2096	xtelij(ixt,il,i,j)=zxtice(ixt,il)+zxtliq(ixt,il)
	2097	enddo !do ixt = 1, ntraciso
	2098	enddo !do il=1,ncum
	2099
	2100	#ifdef ISOVERIF
	2101	if ((j.eq.15).and.(i.eq.15)) then
	2102	il=2722
	2103	if (il.le.ncum) then
	2104	write(,) 'cv30_routines tmp 2194, il,i,j=',il,i,j
	2105	write(,) 'qent,elij=',qent(il,i,j),elij(il,i,j)
	2106	write(,) 'tgsave,zfice=',t(il,j),zfice(il)
	2107	write(,) 'deltaDqent=',deltaD(xtent(iso_HDO,il,i,j)/qent(il,i,j))
	2108	write(,) 'deltaDelij=',deltaD(xtelij(iso_HDO,il,i,j)/elij(il,i,j))
	2109	write(,) 'deltaDice=',deltaD(zxtice(iso_HDO,il)/(zfice(il)*elij(il,i,j)))
	2110	write(,) 'deltaDliq=',deltaD(zxtliq(iso_HDO,il)/(1.0-zfice(il)*elij(il,i,j)))
	2111	endif
	2112	endif
	2113	#endif
	2114
	2115	#ifdef ISOTRAC
	2116	! write(,) 'cv30_routines tmp 1987,option_traceurs=',
	2117	! : option_traceurs
	2118	if (option_tmin.ge.1) then
	2119	do il=1,ncum
	2120	! write(,) 'cv3 tmp 1991 il,i,j,xtent(:,il,i,j),',
	2121	! : 'tcond(il),rs(il,j)=',
	2122	! : il,i,j,xtent(:,il,i,j),tcond(il),rs(il,j)
[4050]	2123	! colorier la vapeur residuelle selon temperature de
	2124	! condensation, et le condensat en un tag spEcifique
[3927]	2125	if ((elij(il,i,j).gt.0.0).and.(qent(il,i,j).gt.0.0)) then
	2126	if (option_traceurs.eq.17) then
	2127	call iso_recolorise_condensation(qent(il,i,j),elij(il,i,j), &
	2128	& xtent(1,il,i,j),xtelij(1,il,i,j),t(1,j), &
	2129	& 0.0,xtres, &
	2130	& seuil_tag_tmin)
	2131	else !if (option_traceurs.eq.17) then
	2132	! write(,) 'cv3 2002: il,i,j =',il,i,j
	2133	call iso_recolorise_condensation(qent(il,i,j),elij(il,i,j), &
	2134	& xtent(1,il,i,j),xtelij(1,il,i,j),rs(il,j),0.0,xtres, &
	2135	& seuil_tag_tmin)
	2136	endif !if (option_traceurs.eq.17) then
	2137	do ixt=1+niso,ntraciso
	2138	xtent(ixt,il,i,j)=xtres(ixt)
	2139	enddo
	2140	endif !if (cond.gt.0.0) then
	2141	enddo !do il=1,ncum
	2142	#ifdef ISOVERIF
	2143	do il=1,ncum
	2144	call iso_verif_traceur(xtent(1,il,i,j),'cv30_routines 1996')
	2145	call iso_verif_traceur(xtelij(1,il,i,j),'cv30_routines 1997')
	2146	call iso_verif_trac17_q_deltaD(xtent(1,il,i,j), &
	2147	& 'cv30_routines 2042')
	2148	enddo !do il=1,ncum
	2149	#endif
	2150	endif !if (option_tmin.ge.1) then
	2151	#endif
	2152
	2153	! fractionation:
	2154	#ifdef ISOVERIF
	2155	! write(,) 'cv30_routines 2050: avant condiso'
	2156	do il=1,ncum
	2157	if ((i.ge.icb(il)).and.(i.le.inb(il)).and. &
	2158	& (j.ge.(icb(il)-1)).and.(j.le.inb(il))) then
	2159	if (sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95) then
	2160	if (iso_eau.gt.0) then
	2161	call iso_verif_egalite_choix(xtent(iso_eau,il,i,j), &
	2162	& qent(il,i,j),'cv30_routines 1889',errmax,errmaxrel)
	2163	call iso_verif_egalite_choix(xtelij(iso_eau,il,i,j), &
	2164	& elij(il,i,j),'cv30_routines 1890',errmax,errmaxrel)
	2165	endif
	2166	if (iso_HDO.gt.0) then
	2167	call iso_verif_aberrant_choix(xt(iso_HDO,il,i),rr(il,i), &
	2168	& ridicule,deltalim,'cv30_routines 1997')
	2169	call iso_verif_aberrant_choix( &
	2170	& xtent(iso_HDO,il,i,j),qent(il,i,j), &
	2171	& ridicule,deltalim,'cv30_routines 1931')
	2172	call iso_verif_aberrant_choix( &
	2173	& xtelij(iso_HDO,il,i,j),elij(il,i,j), &
	2174	& ridicule,deltalim,'cv30_routines 1993')
	2175	endif !if (iso_HDO.gt.0) then
	2176	#ifdef ISOTRAC
	2177	! write(,) 'cv30_routines tmp 2039 il=',il
	2178	call iso_verif_traceur(xtent(1,il,i,j), &
	2179	& 'cv30_routines 2031')
	2180	call iso_verif_traceur(xtelij(1,il,i,j), &
	2181	& 'cv30_routines 2033')
	2182	#endif
	2183
	2184	endif !if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
	2185	endif !if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
	2186	enddo !do il=1,ncum
	2187	#endif
	2188	! write(,) 'cv30_routine tmp 1984: cond=',elij(il,i,j)
	2189
	2190
	2191	#endif
	2192
	2193	END DO
	2194
	2195	! do k=1,ntra
	2196	! do j=minorig,nl
	2197	! do il=1,ncum
	2198	! if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
	2199	! : (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
	2200	! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
	2201	! : +(1.-sij(il,i,j))*tra(il,nk(il),k)
	2202	! endif
	2203	! enddo
	2204	! enddo
	2205	! enddo
	2206
	2207
	2208	! *** if no air can entrain at level i assume that updraft detrains
	2209	! ***
	2210	! *** at that level and calculate detrained air flux and properties
	2211	! ***
	2212
	2213
	2214	! @ do 170 i=icb(il),inb(il)
	2215
	2216	DO il = 1, ncum
	2217	IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN
	2218	! @ if(nent(il,i).eq.0)then
	2219	ment(il, i, i) = m(il, i)
	2220	qent(il, i, i) = rr(il, nk(il)) - ep(il, i)*clw(il, i)
	2221	uent(il, i, i) = u(il, nk(il))
	2222	vent(il, i, i) = v(il, nk(il))
	2223	elij(il, i, i) = clw(il, i)
	2224	! MAF sij(il,i,i)=1.0
	2225	sij(il, i, i) = 0.0
	2226	#ifdef ISO
	2227	do ixt = 1, ntraciso
	2228	xtent(ixt,il,i,i)=xt(ixt,il,nk(il))-ep(il,i)*xtclw(ixt,il,i)
	2229	! xtent(ixt,il,i,i)=xt(ixt,il,nk(il))-xtep(ixt,il,i)*xtclw(ixt,il,i)
	2230	! le 7 mai: on supprime xtep
	2231	xtelij(ixt,il,i,i)=xtclw(ixt,il,i) ! rq: ne sera pas utilise ensuite
	2232	enddo !do ixt = 1, ntraciso
	2233
	2234	#ifdef ISOVERIF
	2235	if (iso_eau.gt.0) then
	2236	call iso_verif_egalite_choix(xtelij(iso_eau,il,i,i), &
	2237	& elij(il,i,i),'cv30_mixing 2117',errmax,errmaxrel)
	2238	endif !if (iso_eau.gt.0) then
	2239	#endif
	2240
	2241	#ifdef ISOTRAC
	2242	if (option_tmin.ge.1) then
[4050]	2243	! colorier la vapeur residuelle selon temperature de
	2244	! condensation, et le condensat en un tag specifique
[3927]	2245	! write(,) 'cv3 tmp 2095 il,i,j,xtent(:,il,i,j)=',
	2246	! : il,i,j,xtent(:,il,i,j)
	2247	if ((elij(il,i,i).gt.0.0).and.(qent(il,i,i).gt.0.0)) then
	2248	if (option_traceurs.eq.17) then
	2249	call iso_recolorise_condensation(qent(il,i,i), &
	2250	& elij(il,i,i), &
	2251	& xt(1,il,nk(il)),xtclw(1,il,i),t(il,i),ep(il,i), &
	2252	& xtres, &
	2253	& seuil_tag_tmin)
	2254	else !if (option_traceurs.eq.17) then
	2255	call iso_recolorise_condensation(qent(il,i,i), &
	2256	& elij(il,i,i), &
	2257	& xt(1,il,nk(il)),xtclw(1,il,i),rs(il,i),ep(il,i), &
	2258	& xtres, &
	2259	& seuil_tag_tmin)
	2260	endif !if (option_traceurs.eq.17) then
	2261	do ixt=1+niso,ntraciso
	2262	xtent(ixt,il,i,i)=xtres(ixt)
	2263	enddo
	2264	#ifdef ISOVERIF
	2265	do ixt=1,niso
	2266	call iso_verif_egalite_choix(xtres(ixt),xtent(ixt,il,i,i), &
	2267	& 'cv30_routines 2102',errmax,errmaxrel)
	2268	call iso_verif_trac17_q_deltaD(xtent(1,il,i,j), &
	2269	& 'cv30_routines 2154')
	2270	enddo
	2271	#endif
	2272	endif !if (cond.gt.0.0) then
	2273
	2274	#ifdef ISOVERIF
	2275	call iso_verif_egalite_choix(xtent(iso_eau,il,i,i), &
	2276	& qent(il,i,i),'cv30_routines 2103',errmax,errmaxrel)
	2277	call iso_verif_traceur(xtent(1,il,i,i),'cv30_routines 2095')
	2278	call iso_verif_traceur(xtelij(1,il,i,i),'cv30_routines 2096')
	2279	#endif
	2280	endif !if (option_tmin.ge.1) then
	2281	#endif
	2282
	2283	#endif
	2284	END IF
	2285	END DO
	2286	END DO
	2287
	2288	! do j=1,ntra
	2289	! do i=minorig+1,nl
	2290	! do il=1,ncum
	2291	! if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
	2292	! traent(il,i,i,j)=tra(il,nk(il),j)
	2293	! endif
	2294	! enddo
	2295	! enddo
	2296	! enddo
	2297
	2298	DO j = minorig, nl
	2299	DO i = minorig, nl
	2300	DO il = 1, ncum
	2301	IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<= &
	2302	inb(il))) THEN
	2303	sigij(il, i, j) = sij(il, i, j)
	2304	END IF
	2305	END DO
	2306	END DO
	2307	END DO
	2308	! @ enddo
	2309
	2310	! @170 continue
	2311
	2312	! =====================================================================
	2313	! --- NORMALIZE ENTRAINED AIR MASS FLUXES
	2314	! --- TO REPRESENT EQUAL PROBABILITIES OF MIXING
	2315	! =====================================================================
	2316
	2317	! ym call zilch(asum,ncum*nd)
	2318	! ym call zilch(bsum,ncum*nd)
	2319	! ym call zilch(csum,ncum*nd)
	2320	CALL zilch(asum, nloc*nd)
	2321	CALL zilch(csum, nloc*nd)
	2322	CALL zilch(csum, nloc*nd)
	2323
	2324	DO il = 1, ncum
	2325	lwork(il) = .FALSE.
	2326	END DO
	2327
	2328	DO i = minorig + 1, nl
	2329
	2330	num1 = 0
	2331	DO il = 1, ncum
	2332	IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1
	2333	END DO
	2334	IF (num1<=0) GO TO 789
	2335
	2336
	2337	DO il = 1, ncum
	2338	IF (i>=icb(il) .AND. i<=inb(il)) THEN
	2339	lwork(il) = (nent(il,i)/=0)
	2340	qp = rr(il, 1) - ep(il, i)*clw(il, i)
	2341	anum = h(il, i) - hp(il, i) - lv(il, i)*(qp-rs(il,i)) + &
	2342	(cpv-cpd)t(il, i)(qp-rr(il,i))
	2343	denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-qp) + &
	2344	(cpd-cpv)t(il, i)(rr(il,i)-qp)
	2345	IF (abs(denom)<0.01) denom = 0.01
	2346	scrit(il) = anum/denom
	2347	alt = qp - rs(il, i) + scrit(il)*(rr(il,i)-qp)
	2348	IF (scrit(il)<=0.0 .OR. alt<=0.0) scrit(il) = 1.0
	2349	smax(il) = 0.0
	2350	asij(il) = 0.0
	2351	END IF
	2352	END DO
	2353
	2354	DO j = nl, minorig, -1
	2355
	2356	num2 = 0
	2357	DO il = 1, ncum
	2358	IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
	2359	il)-1) .AND. j<=inb(il) .AND. lwork(il)) num2 = num2 + 1
	2360	END DO
	2361	IF (num2<=0) GO TO 175
	2362
	2363	DO il = 1, ncum
	2364	IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
	2365	il)-1) .AND. j<=inb(il) .AND. lwork(il)) THEN
	2366
	2367	IF (sij(il,i,j)>1.0E-16 .AND. sij(il,i,j)<0.95) THEN
	2368	wgh = 1.0
	2369	IF (j>i) THEN
	2370	sjmax = amax1(sij(il,i,j+1), smax(il))
	2371	sjmax = amin1(sjmax, scrit(il))
	2372	smax(il) = amax1(sij(il,i,j), smax(il))
	2373	sjmin = amax1(sij(il,i,j-1), smax(il))
	2374	sjmin = amin1(sjmin, scrit(il))
	2375	IF (sij(il,i,j)<(smax(il)-1.0E-16)) wgh = 0.0
	2376	smid = amin1(sij(il,i,j), scrit(il))
	2377	ELSE
	2378	sjmax = amax1(sij(il,i,j+1), scrit(il))
	2379	smid = amax1(sij(il,i,j), scrit(il))
	2380	sjmin = 0.0
	2381	IF (j>1) sjmin = sij(il, i, j-1)
	2382	sjmin = amax1(sjmin, scrit(il))
	2383	END IF
	2384	delp = abs(sjmax-smid)
	2385	delm = abs(sjmin-smid)
	2386	asij(il) = asij(il) + wgh*(delp+delm)
	2387	ment(il, i, j) = ment(il, i, j)(delp+delm)wgh
	2388	END IF
	2389	END IF
	2390	END DO
	2391
	2392	175 END DO
	2393
	2394	DO il = 1, ncum
	2395	IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
	2396	asij(il) = amax1(1.0E-16, asij(il))
	2397	asij(il) = 1.0/asij(il)
	2398	asum(il, i) = 0.0
	2399	bsum(il, i) = 0.0
	2400	csum(il, i) = 0.0
	2401	END IF
	2402	END DO
	2403
	2404	DO j = minorig, nl
	2405	DO il = 1, ncum
	2406	IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
	2407	il)-1) .AND. j<=inb(il)) THEN
	2408	ment(il, i, j) = ment(il, i, j)*asij(il)
	2409	END IF
	2410	END DO
	2411	END DO
	2412
	2413	DO j = minorig, nl
	2414	DO il = 1, ncum
	2415	IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
	2416	il)-1) .AND. j<=inb(il)) THEN
	2417	asum(il, i) = asum(il, i) + ment(il, i, j)
	2418	ment(il, i, j) = ment(il, i, j)*sig(il, j)
	2419	bsum(il, i) = bsum(il, i) + ment(il, i, j)
	2420	END IF
	2421	END DO
	2422	END DO
	2423
	2424	DO il = 1, ncum
	2425	IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
	2426	bsum(il, i) = amax1(bsum(il,i), 1.0E-16)
	2427	bsum(il, i) = 1.0/bsum(il, i)
	2428	END IF
	2429	END DO
	2430
	2431	DO j = minorig, nl
	2432	DO il = 1, ncum
	2433	IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
	2434	il)-1) .AND. j<=inb(il)) THEN
	2435	ment(il, i, j) = ment(il, i, j)asum(il, i)bsum(il, i)
	2436	END IF
	2437	END DO
	2438	END DO
	2439
	2440	DO j = minorig, nl
	2441	DO il = 1, ncum
	2442	IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
	2443	il)-1) .AND. j<=inb(il)) THEN
	2444	csum(il, i) = csum(il, i) + ment(il, i, j)
	2445	END IF
	2446	END DO
	2447	END DO
	2448
	2449	DO il = 1, ncum
	2450	IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
	2451	csum(il,i)<m(il,i)) THEN
	2452	nent(il, i) = 0
	2453	ment(il, i, i) = m(il, i)
	2454	qent(il, i, i) = rr(il, 1) - ep(il, i)*clw(il, i)
	2455	uent(il, i, i) = u(il, nk(il))
	2456	vent(il, i, i) = v(il, nk(il))
	2457	elij(il, i, i) = clw(il, i)
	2458	! MAF sij(il,i,i)=1.0
	2459	sij(il, i, i) = 0.0
	2460	#ifdef ISO
	2461	do ixt = 1, ntraciso
	2462	! xtent(ixt,il,i,i)=xt(ixt,il,1)-xtep(ixt,il,i)*xtclw(ixt,il,i)
	2463	xtent(ixt,il,i,i)=xt(ixt,il,1)-ep(il,i)*xtclw(ixt,il,i)
	2464	xtelij(ixt,il,i,i)=xtclw(ixt,il,i) ! rq: ne sera pas utilise ensuite
	2465	enddo
	2466	#endif
	2467
	2468	#ifdef ISOVERIF
	2469	if (iso_eau.gt.0) then
	2470	call iso_verif_egalite_choix(xtelij(iso_eau,il,i,i), &
	2471	& elij(il,i,i),'cv30_mixing 2354',errmax,errmaxrel)
	2472	endif !if (iso_eau.gt.0) then
	2473	#endif
	2474
	2475	#ifdef ISOTRAC
	2476	if (option_tmin.ge.1) then
[4050]	2477	! colorier la vapeur residuelle selon temperature de
	2478	! condensation, et le condensat en un tag specifique
[3927]	2479	! write(,) 'cv3 tmp 2314 il,i,j,xtent(:,il,i,j)=',
	2480	! : il,i,j,xtent(:,il,i,j)
	2481	if ((elij(il,i,i).gt.0.0).and.(qent(il,i,i).gt.0.0)) then
	2482	if (option_traceurs.eq.17) then
	2483	call iso_recolorise_condensation(qent(il,i,i), &
	2484	& elij(il,i,i), &
	2485	& xt(1,il,1),xtclw(1,il,i),t(il,i),ep(il,i), &
	2486	& xtres, &
	2487	& seuil_tag_tmin)
	2488	else !if (option_traceurs.eq.17) then
	2489	call iso_recolorise_condensation(qent(il,i,i), &
	2490	& elij(il,i,i), &
	2491	& xt(1,il,1),xtclw(1,il,i),rs(il,i),ep(il,i), &
	2492	& xtres, &
	2493	& seuil_tag_tmin)
	2494	endif ! if (option_traceurs.eq.17) then
	2495	do ixt=1+niso,ntraciso
	2496	xtent(ixt,il,i,i)=xtres(ixt)
	2497	enddo
	2498	#ifdef ISOVERIF
	2499	do ixt=1,niso
	2500	call iso_verif_egalite_choix(xtres(ixt),xtent(ixt,il,i,i), &
	2501	& 'cv30_routines 2318',errmax,errmaxrel)
	2502	call iso_verif_trac17_q_deltaD(xtent(1,il,i,j), &
	2503	& 'cv30_routines 2383')
	2504	enddo
	2505	#endif
	2506	endif !if (cond.gt.0.0) then
	2507	#ifdef ISOVERIF
	2508	call iso_verif_egalite_choix(xtent(iso_eau,il,i,i), &
	2509	& qent(il,i,i),'cv30_routines 2321',errmax,errmaxrel)
	2510	call iso_verif_traceur(xtent(1,il,i,i),'cv30_routines 2322')
	2511	call iso_verif_traceur(xtelij(1,il,i,i),'cv30_routines 2323')
	2512	#endif
	2513	endif !if (option_tmin.ge.1) then
	2514	#endif
	2515	END IF
	2516	END DO ! il
	2517
	2518	! do j=1,ntra
	2519	! do il=1,ncum
	2520	! if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
	2521	! : .and. csum(il,i).lt.m(il,i) ) then
	2522	! traent(il,i,i,j)=tra(il,nk(il),j)
	2523	! endif
	2524	! enddo
	2525	! enddo
	2526	789 END DO
	2527
	2528	! MAF: renormalisation de MENT
	2529	DO jm = 1, nd
	2530	DO im = 1, nd
	2531	DO il = 1, ncum
	2532	zm(il, im) = zm(il, im) + (1.-sij(il,im,jm))*ment(il, im, jm)
	2533	END DO
	2534	END DO
	2535	END DO
	2536
	2537	DO jm = 1, nd
	2538	DO im = 1, nd
	2539	DO il = 1, ncum
	2540	IF (zm(il,im)/=0.) THEN
	2541	ment(il, im, jm) = ment(il, im, jm)*m(il, im)/zm(il, im)
	2542	END IF
	2543	END DO
	2544	END DO
	2545	END DO
	2546
	2547	DO jm = 1, nd
	2548	DO im = 1, nd
	2549	DO il = 1, ncum
	2550	qents(il, im, jm) = qent(il, im, jm)
	2551	ments(il, im, jm) = ment(il, im, jm)
	2552	END DO
	2553	END DO
	2554	END DO
	2555
	2556
	2557	#ifdef ISO
	2558	!c--debug
	2559	#ifdef ISOVERIF
	2560	do im = 1, nd
	2561	do jm = 1, nd
	2562	do il = 1, ncum
	2563	if (iso_eau.gt.0) then
	2564	call iso_verif_egalite_choix(xtelij(iso_eau,il,im,jm), &
	2565	& elij(il,im,jm),'cv30_mixing 2110',errmax,errmaxrel)
	2566	call iso_verif_egalite_choix(xtent(iso_eau,il,im,jm), &
	2567	& qent(il,im,jm),'cv30_mixing 2112',errmax,errmaxrel)
	2568	endif !if (iso_eau.gt.0) then
	2569	#ifdef ISOTRAC
	2570	call iso_verif_traceur_justmass(xtelij(1,il,im,jm), &
	2571	& 'cv30_routine 2250')
	2572	#endif
	2573	enddo !do il = 1, nloc
	2574	enddo !do jm = 1, klev
	2575	enddo !do im = 1, klev
	2576	#endif
	2577	#endif
	2578
	2579	#ifdef ISO
	2580	#ifdef ISOTRAC
[4050]	2581	! seulement a la fin on taggue le condensat
[3927]	2582	if (option_cond.ge.1) then
	2583	do im = 1, nd
	2584	do jm = 1, nd
	2585	do il = 1, ncum
[4050]	2586	! colorier le condensat en un tag specifique
[3927]	2587	do ixt=niso+1,ntraciso
	2588	if (index_zone(ixt).eq.izone_cond) then
	2589	xtelij(ixt,il,im,jm)=xtelij(index_iso(ixt),il,im,jm)
	2590	else !if (index_zone(ixt).eq.izone_cond) then
	2591	xtelij(ixt,il,im,jm)=0.0
	2592	endif !if (index_zone(ixt).eq.izone_cond) then
	2593	enddo !do ixt=1,ntraciso
	2594	#ifdef ISOVERIF
	2595	call iso_verif_egalite_choix(xtelij(iso_eau,il,im,jm), &
	2596	& elij(il,im,jm),'cv30_routines 2408',errmax,errmaxrel)
	2597	call iso_verif_traceur(xtelij(1,il,im,jm), &
	2598	& 'condiso_liq_ice_vectiso_trac 358')
	2599	#endif
	2600	enddo !do il = 1, ncum
	2601	enddo !do jm = 1, nd
	2602	enddo !do im = 1, nd
	2603	do im = 1, nd
	2604	do il = 1, ncum
[4050]	2605	! colorier le condensat en un tag specifique
[3927]	2606	do ixt=niso+1,ntraciso
	2607	if (index_zone(ixt).eq.izone_cond) then
	2608	xtclw(ixt,il,im)=xtclw(index_iso(ixt),il,im)
	2609	else !if (index_zone(ixt).eq.izone_cond) then
	2610	xtclw(ixt,il,im)=0.0
	2611	endif !if (index_zone(ixt).eq.izone_cond) then
	2612	enddo !do ixt=1,ntraciso
	2613	#ifdef ISOVERIF
	2614	call iso_verif_egalite_choix(xtclw(iso_eau,il,im), &
	2615	& clw(il,im),'cv30_routines 2427',errmax,errmaxrel)
	2616	call iso_verif_traceur(xtclw(1,il,im), &
	2617	& 'condiso_liq_ice_vectiso_trac 358')
[4143]	2618	if (iso_verif_positif_nostop(xtclw(itZonIso( &
[3927]	2619	& izone_cond,iso_eau),i,k)-xtclw(iso_eau,i,k) &
	2620	& ,'cv30_routines 909').eq.1) then
	2621	write(,) 'i,k=',i,k
	2622	write(,) 'xtclw=',xtclw(:,i,k)
	2623	write(,) 'niso,ntraciso,index_zone,izone_cond=', &
	2624	& niso,ntraciso,index_zone,izone_cond
	2625	stop
[4143]	2626	endif !if (iso_verif_positif_nostop(xtclw(itZonIso(
[3927]	2627	#endif
	2628	enddo !do il = 1, ncum
	2629	enddo !do im = 1, nd
	2630	! write(,) 'xtclw(:,1,2)=',xtclw(:,1,2)
	2631	endif !if (option_tmin.eq.1) then
	2632	#endif
	2633	#endif
	2634
	2635	RETURN
	2636	END SUBROUTINE cv30_mixing
	2637
	2638
	2639	SUBROUTINE cv30_unsat(nloc, ncum, nd, na, ntra, icb, inb, t, rr, rs, gz, u, &
	2640	v, tra, p, ph, th, tv, lv, cpn, ep, sigp, clw, m, ment, elij, delt, plcl, &
	2641	mp, rp, up, vp, trap, wt, water, evap, b & ! RomP-jyg
	2642	, wdtraina, wdtrainm & ! 26/08/10 RomP-jyg
	2643	#ifdef ISO
	2644	& ,xt,xtclw,xtelij &
	2645	& ,xtp,xtwater,xtevap,xtwdtraina &
	2646	#endif
	2647	& )
	2648	#ifdef ISO
[4491]	2649	use infotrac_phy, ONLY: ntraciso=>ntiso, niso
[3927]	2650	use isotopes_mod, ONLY: essai_convergence, iso_eau,iso_HDO,ridicule
[4491]	2651	use isotopes_routines_mod, ONLY: appel_stewart_vectall,appel_stewart_debug
[3927]	2652	#ifdef ISOVERIF
	2653	use isotopes_verif_mod, ONLY: errmax,errmaxrel, &
	2654	iso_verif_egalite_choix, iso_verif_noNaN,iso_verif_aberrant, &
	2655	iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
	2656	iso_verif_egalite_nostop,iso_verif_aberrant_nostop,deltaD,iso_verif_noNaN_nostop, &
	2657	iso_verif_positif,iso_verif_egalite_vect2D
	2658	#endif
	2659	#ifdef ISOTRAC
	2660	use isotrac_mod, only: option_cond,izone_cond
[4143]	2661	use infotrac_phy, ONLY: itZonIso
[3927]	2662	#ifdef ISOVERIF
	2663	use isotopes_verif_mod, ONLY: iso_verif_traceur_justmass, &
	2664	& iso_verif_traceur
	2665	use isotrac_routines_mod, ONLY: iso_verif_traceur_pbidouille
	2666	#endif
	2667	#endif
	2668	#endif
	2669
	2670	IMPLICIT NONE
	2671
	2672
	2673	include "cvthermo.h"
	2674	include "cv30param.h"
	2675	include "cvflag.h"
	2676
	2677	! inputs:
	2678	INTEGER ncum, nd, na, ntra, nloc
	2679	INTEGER icb(nloc), inb(nloc)
	2680	REAL delt, plcl(nloc)
	2681	REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
	2682	REAL u(nloc, nd), v(nloc, nd)
	2683	REAL tra(nloc, nd, ntra)
	2684	REAL p(nloc, nd), ph(nloc, nd+1)
	2685	REAL th(nloc, na), gz(nloc, na)
	2686	REAL lv(nloc, na), ep(nloc, na), sigp(nloc, na), clw(nloc, na)
	2687	REAL cpn(nloc, na), tv(nloc, na)
	2688	REAL m(nloc, na), ment(nloc, na, na), elij(nloc, na, na)
	2689	#ifdef ISO
	2690	real xt(ntraciso,nloc,nd), xtclw(ntraciso,nloc,na)
	2691	real xtelij(ntraciso,nloc,na,na)
	2692	! real xtep(ntraciso,nloc,na) ! le 7 mai: on supprime xtep
	2693	#endif
	2694
	2695	! outputs:
	2696	REAL mp(nloc, na), rp(nloc, na), up(nloc, na), vp(nloc, na)
	2697	REAL water(nloc, na), evap(nloc, na), wt(nloc, na)
	2698	REAL trap(nloc, na, ntra)
	2699	REAL b(nloc, na)
	2700	! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
	2701	! lascendance adiabatique et des flux melanges Pa et Pm.
	2702	! Distinction des wdtrain
	2703	! Pa = wdtrainA Pm = wdtrainM
	2704	REAL wdtraina(nloc, na), wdtrainm(nloc, na)
	2705
	2706	#ifdef ISO
	2707	real xtp(ntraciso,nloc,na)
	2708	real xtwater(ntraciso,nloc,na), xtevap(ntraciso,nloc,na)
	2709	real xtwdtraina(ntraciso,nloc,na)
	2710	#endif
	2711
	2712	! local variables
	2713	INTEGER i, j, k, il, num1
	2714	REAL tinv, delti
	2715	REAL awat, afac, afac1, afac2, bfac
	2716	REAL pr1, pr2, sigt, b6, c6, revap, tevap, delth
	2717	REAL amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
	2718	REAL ampmax
	2719	REAL lvcp(nloc, na)
	2720	REAL wdtrain(nloc)
	2721	LOGICAL lwork(nloc)
	2722
	2723	#ifdef ISO
	2724	integer ixt
	2725	real xtawat(ntraciso)
	2726	REAL xtwdtrain(ntraciso,nloc)
	2727	! logical negation
	2728	real rpprec(nloc,na)
	2729	!#ifdef ISOVERIF
	2730	! integer iso_verif_aberrant_nostop
	2731	!#ifdef ISOTRAC
	2732	! integer iso_verif_traceur_choix_nostop
	2733	! integer iso_verif_positif_nostop
	2734	!#endif
	2735	!#endif
	2736	#endif
	2737
	2738
	2739	! ------------------------------------------------------
	2740	!#ifdef ISOVERIF
[4050]	2741	! write(,) 'cv30_routines 2382: entree dans cv3_unsat'
[3927]	2742	!#endif
	2743
	2744	delti = 1./delt
	2745	tinv = 1./3.
	2746
	2747	mp(:, :) = 0.
	2748	#ifdef ISO
[4050]	2749	! initialisation plus complete de water et rp
[3927]	2750	water(:,:)=0.0
	2751	xtwater(:,:,:)=0.0
	2752	rp(:,:)=0.0
	2753	xtp(:,:,:)=0.0
	2754	#endif
	2755
	2756	DO i = 1, nl
	2757	DO il = 1, ncum
	2758	mp(il, i) = 0.0
	2759	rp(il, i) = rr(il, i)
	2760	up(il, i) = u(il, i)
	2761	vp(il, i) = v(il, i)
	2762	wt(il, i) = 0.001
	2763	water(il, i) = 0.0
	2764	evap(il, i) = 0.0
	2765	b(il, i) = 0.0
	2766	lvcp(il, i) = lv(il, i)/cpn(il, i)
	2767
	2768	#ifdef ISO
	2769	rpprec(il,i)=rp(il,i)
	2770	do ixt=1,ntraciso
	2771	xtp(ixt,il,i)=xt(ixt,il,i)
	2772	xtwater(ixt,il,i)=0.0
	2773	xtevap(ixt,il,i)=0.0
	2774	enddo
	2775	!-- debug
	2776	#ifdef ISOVERIF
	2777	if(iso_eau.gt.0) then
	2778	call iso_verif_egalite_choix(xt(iso_eau,il,i),rr(il,i), &
	2779	& 'cv30_unsat 2245 ',errmax,errmaxrel)
	2780	call iso_verif_egalite_choix(xtp(iso_eau,il,i),rp(il,i), &
	2781	& 'cv30_unsat 2247 ',errmax,errmaxrel)
	2782	endif !if(iso_eau.gt.0) then
	2783	#ifdef ISOTRAC
	2784	call iso_verif_traceur(xt(1,il,i),'cv30_routine 2410')
	2785	call iso_verif_traceur(xtp(1,il,i),'cv30_routine 2411')
	2786	#endif
	2787	#endif
	2788	#endif
	2789
	2790	END DO
	2791	END DO
	2792
	2793	! do k=1,ntra
	2794	! do i=1,nd
	2795	! do il=1,ncum
	2796	! trap(il,i,k)=tra(il,i,k)
	2797	! enddo
	2798	! enddo
	2799	! enddo
	2800	! ! RomP >>>
	2801	DO i = 1, nd
	2802	DO il = 1, ncum
	2803	wdtraina(il, i) = 0.0
	2804	wdtrainm(il, i) = 0.0
	2805	END DO
	2806	END DO
	2807	! ! RomP <<<
	2808
	2809	! * check whether ep(inb)=0, if so, skip precipitating *
	2810	! * downdraft calculation *
	2811
	2812
	2813	DO il = 1, ncum
	2814	lwork(il) = .TRUE.
	2815	IF (ep(il,inb(il))<0.0001) lwork(il) = .FALSE.
	2816	END DO
	2817
	2818	CALL zilch(wdtrain, ncum)
	2819	#ifdef ISO
	2820	call zilch(xtwdtrain,ncum*ntraciso)
	2821	#endif
	2822
	2823	DO i = nl + 1, 1, -1
	2824
	2825	num1 = 0
	2826	DO il = 1, ncum
	2827	IF (i<=inb(il) .AND. lwork(il)) num1 = num1 + 1
	2828	END DO
	2829	IF (num1<=0) GO TO 400
	2830
	2831
	2832	! * integrate liquid water equation to find condensed water *
	2833	! * and condensed water flux *
	2834
	2835
	2836
	2837	! * begin downdraft loop *
	2838
	2839
	2840
	2841	! * calculate detrained precipitation *
	2842
	2843	DO il = 1, ncum
	2844	IF (i<=inb(il) .AND. lwork(il)) THEN
	2845	IF (cvflag_grav) THEN
	2846	wdtrain(il) = gravep(il, i)m(il, i)*clw(il, i)
	2847	wdtraina(il, i) = wdtrain(il)/grav ! Pa 26/08/10 RomP
	2848	#ifdef ISO
	2849	do ixt=1,ntraciso
	2850	! xtwdtrain(ixt,il)=gravxtep(ixt,il,i)m(il,i)*xtclw(ixt,il,i)
	2851	xtwdtrain(ixt,il)=gravep(il,i)m(il,i)*xtclw(ixt,il,i)
	2852	enddo
	2853	!--debug:
	2854	#ifdef ISOVERIF
	2855	if (iso_eau.gt.0) then
	2856	call iso_verif_egalite_choix(xtwdtrain(iso_eau,il), &
	2857	& wdtrain(il),'cv30_routines 2313',errmax,errmaxrel)
	2858	endif !if (iso_eau.gt.0) then
	2859	#ifdef ISOTRAC
	2860	call iso_verif_traceur(xtwdtrain(1,il),'cv30_routine 2480')
	2861	#endif
	2862	#endif
	2863	!--end debug
	2864	#endif
	2865
	2866	ELSE
	2867	wdtrain(il) = 10.0ep(il, i)m(il, i)*clw(il, i)
	2868	wdtraina(il, i) = wdtrain(il)/10. ! Pa 26/08/10 RomP
	2869	#ifdef ISO
	2870	do ixt=1,ntraciso
	2871	! xtwdtrain(ixt,il)=10.0xtep(ixt,il,i)m(il,i)*xtclw(ixt,il,i)
	2872	xtwdtrain(ixt,il)=10.0ep(il,i)m(il,i)*xtclw(ixt,il,i)
	2873	xtwdtraina(ixt,il, i) = xtwdtrain(ixt,il)/10.
	2874	enddo
	2875	#endif
	2876	END IF
	2877	END IF
	2878	END DO
	2879
	2880	IF (i>1) THEN
	2881
	2882	DO j = 1, i - 1
	2883	DO il = 1, ncum
	2884	IF (i<=inb(il) .AND. lwork(il)) THEN
	2885	awat = elij(il, j, i) - (1.-ep(il,i))*clw(il, i)
	2886	awat = amax1(awat, 0.0)
	2887	#ifdef ISO
	2888	! precip mixed drafts computed from: xtawat/xtelij = awat/elij
	2889	if (elij(il,j,i).ne.0.0) then
	2890	do ixt=1,ntraciso
	2891	xtawat(ixt)=xtelij(ixt,il,j,i)*(awat/elij(il,j,i))
	2892	xtawat(ixt)=amax1(xtawat(ixt),0.0)
	2893	enddo
	2894	!! xtawat(ixt)=amin1(xtawat(ixt),xtelij(ixt,il,j,i)) !security..
	2895	else
	2896	do ixt=1,ntraciso
	2897	xtawat(ixt)=0.0
	2898	enddo !do ixt=1,niso
	2899	endif
	2900
	2901	#ifdef ISOVERIF
	2902	if (iso_eau.gt.0) then
	2903	call iso_verif_egalite_choix(xtawat(iso_eau), &
	2904	& awat,'cv30_routines 2391',errmax,errmaxrel)
	2905	endif !if (iso_eau.gt.0) then
	2906	#ifdef ISOTRAC
	2907	call iso_verif_traceur(xtawat(1),'cv30_routine 2522')
	2908	#endif
	2909	#endif
	2910	#endif
	2911	IF (cvflag_grav) THEN
	2912	wdtrain(il) = wdtrain(il) + gravawatment(il, j, i)
	2913	#ifdef ISO
	2914	do ixt=1,ntraciso
	2915	xtwdtrain(ixt,il)=xtwdtrain(ixt,il) &
	2916	& +gravxtawat(ixt)ment(il,j,i)
	2917	enddo !do ixt=1,ntraciso
	2918	#endif
	2919	ELSE
	2920	wdtrain(il) = wdtrain(il) + 10.0awatment(il, j, i)
	2921	#ifdef ISO
	2922	do ixt=1,ntraciso
	2923	xtwdtrain(ixt,il)=xtwdtrain(ixt,il) &
	2924	& +10.0xtawat(ixt)ment(il,j,i)
	2925	enddo !!do ixt=1,ntraciso
	2926	#endif
	2927	END IF !if (cvflag_grav) then
	2928	#ifdef ISO
	2929	!--debug:
	2930	#ifdef ISOVERIF
	2931	if (iso_eau.gt.0) then
	2932	call iso_verif_egalite_choix(xtwdtrain(iso_eau,il), &
	2933	& wdtrain(il),'cv30_routines 2366',errmax,errmaxrel)
	2934	endif !if (iso_eau.gt.0) then
	2935	#ifdef ISOTRAC
	2936	call iso_verif_traceur(xtwdtrain(1,il),'cv30_routine 2540')
	2937	if (option_cond.ge.1) then
[4050]	2938	! on verifie que tout le detrainement est tagge condensat
[3927]	2939	if (iso_verif_positif_nostop( &
[4143]	2940	& xtwdtrain(itZonIso(izone_cond,iso_eau),il) &
[3927]	2941	& -xtwdtrain(iso_eau,il), &
	2942	& 'cv30_routines 2795').eq.1) then
	2943	write(,) 'xtwdtrain(:,il)=',xtwdtrain(:,il)
	2944	write(,) 'xtelij(:,il,j,i)=',xtelij(:,il,j,i)
	2945	write(,) 'xtclw(:,il,i)=',xtclw(:,il,i)
	2946	stop
	2947	endif !if (iso_verif_positif_nostop(Pxtisup(iso_eau,il)-
	2948	endif !if (option_cond.ge.1) then
	2949	#endif
	2950	#endif
	2951	#endif
	2952
	2953	END IF !IF (i<=inb(il) .AND. lwork(il)) THEN
	2954	END DO
	2955	END DO
	2956	DO il = 1, ncum
	2957	IF (cvflag_grav) THEN
	2958	wdtrainm(il, i) = wdtrain(il)/grav - wdtraina(il, i) ! Pm 26/08/10 RomP
	2959	ELSE
	2960	wdtrainm(il, i) = wdtrain(il)/10. - wdtraina(il, i) ! Pm 26/08/10 RomP
	2961	END IF
	2962	END DO
	2963
	2964	END IF
	2965
	2966
	2967	! * find rain water and evaporation using provisional *
	2968	! * estimates of rp(i)and rp(i-1) *
	2969
	2970
	2971	DO il = 1, ncum
	2972
	2973	IF (i<=inb(il) .AND. lwork(il)) THEN
	2974
	2975	wt(il, i) = 45.0
	2976
	2977	IF (i<inb(il)) THEN
	2978	rp(il, i) = rp(il, i+1) + (cpd*(t(il,i+1)-t(il, &
	2979	i))+gz(il,i+1)-gz(il,i))/lv(il, i)
	2980	rp(il, i) = 0.5*(rp(il,i)+rr(il,i))
	2981	END IF
	2982	rp(il, i) = amax1(rp(il,i), 0.0)
	2983	rp(il, i) = amin1(rp(il,i), rs(il,i))
	2984	rp(il, inb(il)) = rr(il, inb(il))
	2985
	2986	IF (i==1) THEN
	2987	afac = p(il, 1)(rs(il,1)-rp(il,1))/(1.0E4+2000.0p(il,1)*rs(il,1))
	2988	ELSE
	2989	rp(il, i-1) = rp(il, i) + (cpd*(t(il,i)-t(il, &
	2990	i-1))+gz(il,i)-gz(il,i-1))/lv(il, i)
	2991	rp(il, i-1) = 0.5*(rp(il,i-1)+rr(il,i-1))
	2992	rp(il, i-1) = amin1(rp(il,i-1), rs(il,i-1))
	2993	rp(il, i-1) = amax1(rp(il,i-1), 0.0)
	2994	afac1 = p(il, i)(rs(il,i)-rp(il,i))/(1.0E4+2000.0p(il,i)*rs(il,i) &
	2995	)
	2996	afac2 = p(il, i-1)*(rs(il,i-1)-rp(il,i-1))/ &
	2997	(1.0E4+2000.0p(il,i-1)rs(il,i-1))
	2998	afac = 0.5*(afac1+afac2)
	2999	END IF
	3000	IF (i==inb(il)) afac = 0.0
	3001	afac = amax1(afac, 0.0)
	3002	bfac = 1./(sigd*wt(il,i))
	3003
	3004	! jyg1
	3005	! cc sigt=1.0
	3006	! cc if(i.ge.icb)sigt=sigp(i)
	3007	! prise en compte de la variation progressive de sigt dans
	3008	! les couches icb et icb-1:
	3009	! pour plcl<ph(i+1), pr1=0 & pr2=1
	3010	! pour plcl>ph(i), pr1=1 & pr2=0
	3011	! pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
	3012	! sur le nuage, et pr2 est la proportion sous la base du
	3013	! nuage.
	3014	pr1 = (plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
	3015	pr1 = max(0., min(1.,pr1))
	3016	pr2 = (ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
	3017	pr2 = max(0., min(1.,pr2))
	3018	sigt = sigp(il, i)*pr1 + pr2
	3019	! jyg2
	3020
	3021	b6 = bfac50.sigd(ph(il,i)-ph(il,i+1))sigt*afac
	3022	c6 = water(il, i+1) + bfacwdtrain(il) - 50.sigdbfac(ph(il,i)-ph( &
	3023	il,i+1))*evap(il, i+1)
	3024	IF (c6>0.0) THEN
	3025	revap = 0.5(-b6+sqrt(b6b6+4.*c6))
	3026	evap(il, i) = sigtafacrevap
	3027	water(il, i) = revap*revap
	3028	ELSE
	3029	evap(il, i) = -evap(il, i+1) + 0.02(wdtrain(il)+sigdwt(il,i)* &
	3030	water(il,i+1))/(sigd*(ph(il,i)-ph(il,i+1)))
	3031	END IF
	3032
	3033	#ifdef ISO
[4050]	3034	! ajout cam: eviter les evaporations ou eaux negatives
	3035	! water(il,i)=max(0.0,water(il,i)) ! ceci est toujours verifie
[3927]	3036	#ifdef ISOVERIF
	3037	call iso_verif_positif(water(il,i),'cv30_unsat 2376')
	3038	#endif
	3039	! evap(il,i)=max(0.0,evap(il,i)) ! evap<0 permet la conservation de
	3040	! l'eau
	3041	! fin ajout cam
	3042	#endif
	3043
	3044	! * calculate precipitating downdraft mass flux under *
	3045	! * hydrostatic approximation *
	3046
	3047	IF (i/=1) THEN
	3048
	3049	tevap = amax1(0.0, evap(il,i))
	3050	delth = amax1(0.001, (th(il,i)-th(il,i-1)))
	3051	IF (cvflag_grav) THEN
	3052	mp(il, i) = 100.ginvlvcp(il, i)sigdtevap*(p(il,i-1)-p(il,i))/ &
	3053	delth
	3054	ELSE
	3055	mp(il, i) = 10.lvcp(il, i)sigdtevap(p(il,i-1)-p(il,i))/delth
	3056	END IF
	3057
	3058	! * if hydrostatic assumption fails, *
	3059	! * solve cubic difference equation for downdraft theta *
	3060	! * and mass flux from two simultaneous differential eqns *
	3061
	3062	amfac = sigdsigd70.0ph(il, i)(p(il,i-1)-p(il,i))* &
	3063	(th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
	3064	amp2 = abs(mp(il,i+1)mp(il,i+1)-mp(il,i)mp(il,i))
	3065	IF (amp2>(0.1*amfac)) THEN
	3066	xf = 100.0sigdsigdsigd(ph(il,i)-ph(il,i+1))
	3067	tf = b(il, i) - 5.0(th(il,i)-th(il,i-1))t(il, i)/(lvcp(il,i)* &
	3068	sigd*th(il,i))
	3069	af = xftf + mp(il, i+1)mp(il, i+1)*tinv
	3070	bf = 2.(tinvmp(il,i+1))*3 + tinvmp(il, i+1)xftf + &
	3071	50.(p(il,i-1)-p(il,i))xf*tevap
	3072	fac2 = 1.0
	3073	IF (bf<0.0) fac2 = -1.0
	3074	bf = abs(bf)
	3075	ur = 0.25bfbf - afafaftinvtinv*tinv
	3076	IF (ur>=0.0) THEN
	3077	sru = sqrt(ur)
	3078	fac = 1.0
	3079	IF ((0.5*bf-sru)<0.0) fac = -1.0
	3080	mp(il, i) = mp(il, i+1)tinv + (0.5bf+sru)**tinv + &
	3081	fac(abs(0.5bf-sru))**tinv
	3082	ELSE
	3083	d = atan(2.*sqrt(-ur)/(bf+1.0E-28))
	3084	IF (fac2<0.0) d = 3.14159 - d
	3085	mp(il, i) = mp(il, i+1)tinv + 2.sqrt(aftinv)cos(d*tinv)
	3086	END IF
	3087	mp(il, i) = amax1(0.0, mp(il,i))
	3088
	3089	IF (cvflag_grav) THEN
	3090	! jyg : il y a vraisemblablement une erreur dans la ligne 2
	3091	! suivante:
	3092	! il faut diviser par (mp(il,i)sigdgrav) et non par
	3093	! (mp(il,i)+sigd*0.1).
	3094	! Et il faut bien revoir les facteurs 100.
	3095	b(il, i-1) = b(il, i) + 100.0(p(il,i-1)-p(il,i))tevap/(mp(il, &
	3096	i)+sigd0.1) - 10.0(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i &
	3097	)sigdth(il,i))
	3098	ELSE
	3099	b(il, i-1) = b(il, i) + 100.0(p(il,i-1)-p(il,i))tevap/(mp(il, &
	3100	i)+sigd0.1) - 10.0(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i &
	3101	)sigdth(il,i))
	3102	END IF
	3103	b(il, i-1) = amax1(b(il,i-1), 0.0)
	3104	END IF
	3105
	3106	! *** limit magnitude of mp(i) to meet cfl condition
	3107	! ***
	3108
	3109	ampmax = 2.0(ph(il,i)-ph(il,i+1))delti
	3110	amp2 = 2.0(ph(il,i-1)-ph(il,i))delti
	3111	ampmax = amin1(ampmax, amp2)
	3112	mp(il, i) = amin1(mp(il,i), ampmax)
	3113
	3114	! *** force mp to decrease linearly to zero
	3115	! ***
	3116	! *** between cloud base and the surface
	3117	! ***
	3118
	3119	IF (p(il,i)>p(il,icb(il))) THEN
	3120	mp(il, i) = mp(il, icb(il))*(p(il,1)-p(il,i))/ &
	3121	(p(il,1)-p(il,icb(il)))
	3122	END IF
	3123
	3124	END IF ! i.eq.1
	3125
	3126	! * find mixing ratio of precipitating downdraft *
	3127
	3128
	3129	IF (i/=inb(il)) THEN
	3130
	3131	rp(il, i) = rr(il, i)
	3132
	3133	IF (mp(il,i)>mp(il,i+1)) THEN
	3134
	3135	IF (cvflag_grav) THEN
	3136	rp(il, i) = rp(il, i+1)*mp(il, i+1) + &
	3137	rr(il, i)(mp(il,i)-mp(il,i+1)) + 100.ginv0.5sigd*(ph(il,i &
	3138	)-ph(il,i+1))*(evap(il,i+1)+evap(il,i))
	3139	ELSE
	3140	rp(il, i) = rp(il, i+1)*mp(il, i+1) + &
	3141	rr(il, i)(mp(il,i)-mp(il,i+1)) + 5.sigd*(ph(il,i)-ph(il,i+1 &
	3142	))*(evap(il,i+1)+evap(il,i))
	3143	END IF
	3144	rp(il, i) = rp(il, i)/mp(il, i)
	3145	up(il, i) = up(il, i+1)mp(il, i+1) + u(il, i)(mp(il,i)-mp(il,i+ &
	3146	1))
	3147	up(il, i) = up(il, i)/mp(il, i)
	3148	vp(il, i) = vp(il, i+1)mp(il, i+1) + v(il, i)(mp(il,i)-mp(il,i+ &
	3149	1))
	3150	vp(il, i) = vp(il, i)/mp(il, i)
	3151
	3152	! do j=1,ntra
	3153	! trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
	3154	! testmaf : +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
	3155	! : +tra(il,i,j)*(mp(il,i)-mp(il,i+1))
	3156	! trap(il,i,j)=trap(il,i,j)/mp(il,i)
	3157	! end do
	3158
	3159	ELSE
	3160
	3161	IF (mp(il,i+1)>1.0E-16) THEN
	3162	IF (cvflag_grav) THEN
	3163	rp(il, i) = rp(il, i+1) + 100.ginv0.5sigd(ph(il,i)-ph(il, &
	3164	i+1))*(evap(il,i+1)+evap(il,i))/mp(il, i+1)
	3165	ELSE
	3166	rp(il, i) = rp(il, i+1) + 5.sigd(ph(il,i)-ph(il,i+1))*(evap &
	3167	(il,i+1)+evap(il,i))/mp(il, i+1)
	3168	END IF
	3169	up(il, i) = up(il, i+1)
	3170	vp(il, i) = vp(il, i+1)
	3171
	3172	! do j=1,ntra
	3173	! trap(il,i,j)=trap(il,i+1,j)
	3174	! end do
	3175
	3176	END IF
	3177	END IF
	3178	#ifdef ISO
	3179	rpprec(il,i)=max(rp(il,i),0.0)
	3180	#endif
	3181	rp(il, i) = amin1(rp(il,i), rs(il,i))
	3182	rp(il, i) = amax1(rp(il,i), 0.0)
	3183
	3184	END IF
	3185	END IF
	3186	END DO
	3187
	3188
	3189	#ifdef ISO
	3190	#ifdef ISOVERIF
[4050]	3191	! verif des inputs a appel stewart
[3927]	3192	! write(,) 'cv30_routines 2842 tmp: appel de appel_stewart'
	3193	do il=1,ncum
	3194	if (i.le.inb(il) .and. lwork(il)) then
	3195	if (iso_eau.gt.0) then
	3196	call iso_verif_egalite_choix(xt(iso_eau,il,i), &
	3197	& rr(il,i),'appel_stewart 262, cas 1.1',errmax,errmaxrel)
	3198	endif !if (iso_eau.gt.0) then
	3199	!#ifdef ISOTRAC
	3200	! if (option_tmin.ge.1) then
	3201	! call iso_verif_positif(xtwater(
[4143]	3202	! : itZonIso(izone_cond,iso_eau),il,i+1)
[3927]	3203	! : -xtwater(iso_eau,il,i+1),
	3204	! : 'cv30_routines 3083')
	3205	! endif !if (option_tmin.ge.1) then
	3206	!#endif
	3207	endif
	3208	enddo
	3209	#endif
[4491]	3210
	3211	if (1.eq.0) then
[4050]	3212	! appel de appel_stewart_vectorise
[3927]	3213	call appel_stewart_vectall(lwork,ncum, &
	3214	& ph,t,evap,xtwdtrain, &
	3215	& wdtrain, &
	3216	& water,rr,xt,rs,rpprec,mp,wt, & ! inputs physiques
	3217	& xtwater,xtp, & ! outputs indispensables
	3218	& xtevap, & ! diagnostiques
	3219	& sigd, & ! inputs tunables
	3220	& i,inb, & ! altitude: car cas particulier en INB
	3221	& na,nd,nloc,cvflag_grav,ginv,1e-16)
	3222
[4491]	3223	else !if (1.eq.0) then
	3224	! truc simple sans fractionnement
	3225	! juste pour debuggage
	3226	call appel_stewart_debug(lwork,nloc,inb,na,i, &
	3227	evap,water,rpprec,rr,wdtrain, &
	3228	xtevap,xtwater,xtp,xt,xtwdtrain)
	3229	endif ! if (1.eq.0) then
	3230
	3231
[3927]	3232	#ifdef ISOVERIF
	3233	! write(,) 'cv30_routines 2864 tmp: sortie de appel_stewart'
	3234	! verif des outputs de appel stewart
	3235	do il=1,ncum
	3236	if (i.le.inb(il) .and. lwork(il)) then
	3237	do ixt=1,ntraciso
	3238	call iso_verif_noNAN(xtp(ixt,il,i),'cv30_unsat 3382')
	3239	call iso_verif_noNAN(xtwater(ixt,il,i),'cv30_unsat 3381')
	3240	call iso_verif_noNAN(xtevap(ixt,il,i),'cv30_unsat 2661')
	3241	enddo
	3242	if (iso_eau.gt.0) then
	3243	call iso_verif_egalite_choix(xtp(iso_eau,il,i), &
	3244	& rpprec(il,i),'cv30_unsat 2736',errmax,errmaxrel)
	3245	call iso_verif_egalite_choix(xtwater(iso_eau,il,i), &
	3246	& water(il,i),'cv30_unsat 2747',errmax,errmaxrel)
	3247	! write(,) 'xtwater(4,il,i)=',xtwater(4,il,i)
	3248	! write(,) 'water(il,i)=',water(il,i)
	3249	call iso_verif_egalite_choix(xtevap(iso_eau,il,i), &
	3250	& evap(il,i),'cv30_unsat 2751',errmax,errmaxrel)
	3251	endif !if (iso_eau.gt.0) then
	3252	if ((iso_HDO.gt.0).and. &
	3253	& (rp(il,i).gt.ridicule)) then
	3254	call iso_verif_aberrant(xtp(iso_HDO,il,i)/rpprec(il,i), &
	3255	& 'cv3unsat 2756')
	3256	endif !if ((iso_HDO.gt.0).and.
	3257	#ifdef ISOTRAC
	3258	! if (il.eq.602) then
	3259	! write(,) 'cv30_routine tmp: il,i=',il,i
	3260	! write(,) 'xtp(iso_eau:ntraciso:3,il,i)=',
	3261	! : xtp(iso_eau:ntraciso:3,il,i)
	3262	! endif
	3263	call iso_verif_traceur(xtp(1,il,i),'cv30_routine 2852')
	3264	call iso_verif_traceur(xtwater(1,il,1), &
	3265	& 'cv30_routine 2853 unsat apres appel')
	3266	call iso_verif_traceur_pbidouille(xtwater(1,il,i), &
	3267	& 'cv30_routine 2853b')
	3268	call iso_verif_traceur_justmass(xtevap(1,il,i), &
	3269	& 'cv30_routine 2854')
	3270	! if (option_tmin.ge.1) then
	3271	! call iso_verif_positif(xtwater(
[4143]	3272	! : itZonIso(izone_cond,iso_eau),il,i)
[3927]	3273	! : -xtwater(iso_eau,il,i),
	3274	! : 'cv30_routines 3143')
	3275	! endif !if (option_tmin.ge.1) then
	3276	#endif
	3277	endif !if (i.le.inb(il) .and. lwork(il)) then
	3278	enddo !do il=1,ncum
	3279	#endif
	3280
[4050]	3281	! equivalent isotopique de rp(il,i)=amin1(rp(il,i),rs(il,i))
[3927]	3282	do il=1,ncum
	3283	if (i.lt.inb(il) .and. lwork(il)) then
	3284
	3285	if (rpprec(il,i).gt.rs(il,i)) then
	3286	if (rs(il,i).le.0) then
	3287	write(,) 'cv3unsat 2640'
	3288	stop
	3289	endif
	3290	do ixt=1,ntraciso
	3291	xtp(ixt,il,i)=xtp(ixt,il,i)/rpprec(il,i)*rs(il,i)
	3292	xtp(ixt,il,i)=max(0.0,xtp(ixt,il,i))
	3293	enddo !do ixt=1,niso
	3294	#ifdef ISOVERIF
	3295	do ixt=1,ntraciso
	3296	call iso_verif_noNaN(xtp(ixt,il,i),'cv3unsat 2641')
	3297	enddo !do ixt=1,niso
	3298	if (iso_eau.gt.0) then
	3299	! write(,) 'xtp(iso_eau,il,i)=',xtp(iso_eau,il,i)
	3300	call iso_verif_egalite_choix(xtp(iso_eau,il,i),rp(il,i), &
	3301	& 'cv3unsat 2653',errmax,errmaxrel)
	3302	call iso_verif_egalite_choix(xtp(iso_eau,il,i), &
	3303	& rs(il,i),'cv3unsat 2654',errmax,errmaxrel)
	3304	endif
	3305	if ((iso_HDO.gt.0).and. &
	3306	& (rp(il,i).gt.ridicule)) then
	3307	if (iso_verif_aberrant_nostop(xtp(iso_HDO,il,i)/rp(il,i), &
	3308	& 'cv3unsat 2658').eq.1) then
	3309	write(,) 'rpprec(il,i),rs(il,i),rp(il,i)=', &
	3310	& rpprec(il,i),rs(il,i),rp(il,i)
	3311	stop
	3312	endif
	3313	endif
	3314	#ifdef ISOTRAC
	3315	call iso_verif_traceur(xtp(1,il,i),'cv30_routine 2893')
	3316	#endif
	3317	#endif
	3318	rpprec(il,i)=rs(il,i)
	3319	endif !if (rp(il,i).gt.rs(il,i)) then
	3320	endif !if (i.lt.INB et lwork)
	3321	enddo ! il=1,ncum
	3322	#endif
	3323
	3324	400 END DO
	3325
	3326
	3327	! fin de la boucle en i (altitude)
	3328	#ifdef ISO
	3329	write(,) 'nl=',nl,'nd=',nd,'; ncum=',ncum
	3330	#ifdef ISOVERIF
	3331	do i=1,nl !nl
	3332	do il=1,ncum
	3333	if (iso_eau.gt.0) then
	3334	! write(,) 'cv30_routines 2767:i,il,lwork(il),inb(il)=',
	3335	! : i,il,lwork(il),inb(il)
	3336	! write(,) 'rp(il,i),xtp(iso_eau,il,i)=',
	3337	! : rp(il,i),xtp(iso_eau,il,i)
	3338	call iso_verif_egalite_choix(xt(iso_eau,il,i), &
	3339	& rr(il,i),'cv30_unsat 2668',errmax,errmaxrel)
	3340	call iso_verif_egalite_choix(xtp(iso_eau,il,i), &
	3341	& rp(il,i),'cv30_unsat 2670',errmax,errmaxrel)
	3342	call iso_verif_egalite_choix(xtwater(iso_eau,il,i), &
	3343	& water(il,i),'cv30_unsat 2672',errmax,errmaxrel)
	3344	endif !if (iso_eau.gt.0) then
	3345	!#ifdef ISOTRAC
	3346	! if (iso_verif_traceur_choix_nostop(xtwater(1,il,i),
	3347	! : 'cv30_routine 2982 unsat',errmax,
	3348	! : errmaxrel,ridicule_trac,deltalimtrac).eq.1) then
	3349	! write(,) 'il,i,inb(il),lwork(il)=',
	3350	! : il,i,inb(il),lwork(il)
	3351	! write(,) 'xtwater(:,il,i)=',xtwater(:,il,i)
	3352	! stop
	3353	! endif
	3354	!#endif
	3355	enddo !do il=1,nloc!ncum
	3356	enddo !do i=1,nl!nl
	3357	il=5
	3358	i=39
	3359	write(,) 'cv30_unsat 2780: il,water(il,i),xtwater(iso_eau,il,i)=' &
	3360	,il,water(il,i),xtwater(iso_eau,il,i)
	3361	#endif
	3362	#endif
	3363	RETURN
	3364	END SUBROUTINE cv30_unsat
	3365
	3366	SUBROUTINE cv30_yield(nloc, ncum, nd, na, ntra, icb, inb, delt, t, rr, u, v, &
	3367	tra, gz, p, ph, h, hp, lv, cpn, th, ep, clw, m, tp, mp, rp, up, vp, trap, &
	3368	wt, water, evap, b, ment, qent, uent, vent, nent, elij, traent, sig, tv, &
	3369	tvp, iflag, precip, vprecip, ft, fr, fu, fv, ftra, upwd, dnwd, dnwd0, ma, &
	3370	mike, tls, tps, qcondc, wd &
	3371	#ifdef ISO
	3372	& ,xt,xtclw,xtp,xtwater,xtevap &
	3373	& ,xtent,xtelij,xtprecip,fxt,xtVprecip &
	3374	#ifdef DIAGISO
	3375	& ,fq_detrainement,fq_ddft,fq_fluxmasse,fq_evapprecip &
	3376	& ,fxt_detrainement,fxt_ddft,fxt_fluxmasse,fxt_evapprecip &
	3377	& ,f_detrainement,q_detrainement,xt_detrainement &
	3378	#endif
	3379	#endif
	3380	& )
	3381	#ifdef ISO
[4143]	3382	use infotrac_phy, ONLY: ntraciso=>ntiso, niso, nzone, itZonIso
[3927]	3383	use isotopes_mod, ONLY: essai_convergence,ridicule,iso_eau,iso_HDO,iso_O18
	3384	#ifdef ISOVERIF
	3385	use isotopes_verif_mod, ONLY: errmax,errmaxrel, &
	3386	iso_verif_egalite_choix, iso_verif_noNaN,iso_verif_aberrant, &
	3387	iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
	3388	iso_verif_egalite_nostop,iso_verif_aberrant_nostop,deltaD,iso_verif_noNaN_nostop, &
	3389	iso_verif_positif,iso_verif_egalite_vect2D, &
	3390	iso_verif_aberrant_enc_nostop,iso_verif_aberrant_encadre,iso_verif_o18_aberrant, &
	3391	iso_verif_O18_aberrant_nostop,deltaO
	3392	#endif
	3393	#ifdef ISOTRAC
	3394	use isotrac_mod, only: option_traceurs, &
	3395	izone_revap,izone_poubelle,izone_ddft
	3396	#ifdef ISOVERIF
	3397	use isotopes_verif_mod, ONLY: iso_verif_traceur_choix_nostop,deltalimtrac, &
	3398	& iso_verif_tracpos_choix_nostop,iso_verif_traceur,iso_verif_traceur_justmass
	3399	use isotrac_mod, only: ridicule_trac
	3400	#endif
	3401	#endif
	3402	#endif
	3403
	3404	IMPLICIT NONE
	3405
	3406	include "cvthermo.h"
	3407	include "cv30param.h"
	3408	include "cvflag.h"
	3409	include "conema3.h"
	3410
	3411	! inputs:
	3412	INTEGER ncum, nd, na, ntra, nloc
	3413	INTEGER icb(nloc), inb(nloc)
	3414	REAL delt
	3415	REAL t(nloc, nd), rr(nloc, nd), u(nloc, nd), v(nloc, nd)
	3416	REAL tra(nloc, nd, ntra), sig(nloc, nd)
	3417	REAL gz(nloc, na), ph(nloc, nd+1), h(nloc, na), hp(nloc, na)
	3418	REAL th(nloc, na), p(nloc, nd), tp(nloc, na)
	3419	REAL lv(nloc, na), cpn(nloc, na), ep(nloc, na), clw(nloc, na)
	3420	REAL m(nloc, na), mp(nloc, na), rp(nloc, na), up(nloc, na)
	3421	REAL vp(nloc, na), wt(nloc, nd), trap(nloc, nd, ntra)
	3422	REAL water(nloc, na), evap(nloc, na), b(nloc, na)
	3423	REAL ment(nloc, na, na), qent(nloc, na, na), uent(nloc, na, na)
	3424	! ym real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
	3425	REAL vent(nloc, na, na), elij(nloc, na, na)
	3426	INTEGER nent(nloc, na)
	3427	REAL traent(nloc, na, na, ntra)
	3428	REAL tv(nloc, nd), tvp(nloc, nd)
	3429	#ifdef ISO
	3430	real xt(ntraciso,nloc,nd)
	3431	! real xtep(ntraciso,nloc,na) ! le 7 mai: on supprime xtep
	3432	real xtclw(ntraciso,nloc,na), xtp(ntraciso,nloc,na)
	3433	real xtwater(ntraciso,nloc,na), xtevap(ntraciso,nloc,na)
	3434	real xtent(ntraciso,nloc,na,na), xtelij(ntraciso,nloc,na,na)
	3435	#ifdef ISOVERIF
	3436	CHARACTER (LEN=20) :: modname='cv30_compress'
	3437	CHARACTER (LEN=80) :: abort_message
	3438	#endif
	3439	#endif
	3440
	3441	! input/output:
	3442	INTEGER iflag(nloc)
	3443
	3444	! outputs:
	3445	REAL precip(nloc)
	3446	REAL vprecip(nloc, nd+1)
	3447	REAL ft(nloc, nd), fr(nloc, nd), fu(nloc, nd), fv(nloc, nd)
	3448	REAL ftra(nloc, nd, ntra)
	3449	REAL upwd(nloc, nd), dnwd(nloc, nd), ma(nloc, nd)
	3450	REAL dnwd0(nloc, nd), mike(nloc, nd)
	3451	REAL tls(nloc, nd), tps(nloc, nd)
	3452	REAL qcondc(nloc, nd) ! cld
	3453	REAL wd(nloc) ! gust
	3454	#ifdef ISO
	3455	real xtprecip(ntraciso,nloc), fxt(ntraciso,nloc,nd)
	3456	real xtVprecip(ntraciso,nloc,nd+1)
	3457	#endif
	3458
	3459	! local variables:
	3460	INTEGER i, k, il, n, j, num1
	3461	REAL rat, awat, delti
	3462	REAL ax, bx, cx, dx, ex
	3463	REAL cpinv, rdcp, dpinv
	3464	REAL lvcp(nloc, na), mke(nloc, na)
	3465	REAL am(nloc), work(nloc), ad(nloc), amp1(nloc)
	3466	! !! real up1(nloc), dn1(nloc)
	3467	REAL up1(nloc, nd, nd), dn1(nloc, nd, nd)
	3468	REAL asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
	3469	REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
	3470	REAL siga(nloc, nd), sax(nloc, nd), mac(nloc, nd) ! cld
	3471	#ifdef ISO
	3472	integer ixt
	3473	real xtbx(ntraciso), xtawat(ntraciso)
	3474	! cam debug
[4050]	3475	! pour l'homogeneisation sous le nuage:
[3927]	3476	real frsum(nloc), bxtsum(ntraciso,nloc), fxtsum(ntraciso,nloc)
[4050]	3477	! correction dans calcul tendance liee a Am:
[3927]	3478	real dq_tmp,k_tmp,dx_tmp,R_tmp,dqreste_tmp,dxreste_tmp,kad_tmp
	3479	logical correction_excess_aberrant
	3480	parameter (correction_excess_aberrant=.false.)
[4050]	3481	! correction qui permettait d'eviter deltas et dexcess aberrants. Mais
[3927]	3482	! pb: ne conserve pas la masse d'isotopes!
	3483	#ifdef DIAGISO
[4050]	3484	! diagnostiques juste: tendance des differents processus
[3927]	3485	real fxt_detrainement(ntraciso,nloc,nd)
	3486	real fxt_fluxmasse(ntraciso,nloc,nd)
	3487	real fxt_evapprecip(ntraciso,nloc,nd)
	3488	real fxt_ddft(ntraciso,nloc,nd)
	3489	real fq_detrainement(nloc,nd)
	3490	real q_detrainement(nloc,nd)
	3491	real xt_detrainement(ntraciso,nloc,nd)
	3492	real f_detrainement(nloc,nd)
	3493	real fq_fluxmasse(nloc,nd)
	3494	real fq_evapprecip(nloc,nd)
	3495	real fq_ddft(nloc,nd)
	3496	#endif
	3497	!#ifdef ISOVERIF
	3498	! integer iso_verif_aberrant_nostop
	3499	! real deltaD
	3500	!#endif
	3501	#ifdef ISOTRAC
	3502	! integer iso_verif_traceur_choix_nostop
	3503	! integer iso_verif_tracpos_choix_nostop
	3504	real xtnew(ntraciso)
	3505	! real conversion(niso)
	3506	real fxtYe(niso)
	3507	real fxtqe(niso)
	3508	real fxtXe(niso)
	3509	real fxt_revap(niso)
	3510	real Xe(niso)
	3511	integer ixt_revap,izone
	3512	integer ixt_poubelle, ixt_ddft,iiso
	3513	#endif
	3514	#endif
	3515
	3516
	3517	! -------------------------------------------------------------
	3518
	3519	! initialization:
	3520
	3521	delti = 1.0/delt
	3522
	3523	DO il = 1, ncum
	3524	precip(il) = 0.0
	3525	wd(il) = 0.0 ! gust
	3526	vprecip(il, nd+1) = 0.
	3527	#ifdef ISO
	3528	! cam debug
[4050]	3529	! write(,) 'cv30_routines 3082: entree dans cv3_yield'
[3927]	3530	! en cam debug
	3531	do ixt = 1, ntraciso
	3532	xtprecip(ixt,il)=0.0
	3533	xtVprecip(ixt,il,nd+1)=0.0
	3534	enddo
	3535	#endif
	3536	END DO
	3537
	3538	DO i = 1, nd
	3539	DO il = 1, ncum
	3540	vprecip(il, i) = 0.0
	3541	ft(il, i) = 0.0
	3542	fr(il, i) = 0.0
	3543	fu(il, i) = 0.0
	3544	fv(il, i) = 0.0
	3545	qcondc(il, i) = 0.0 ! cld
	3546	qcond(il, i) = 0.0 ! cld
	3547	nqcond(il, i) = 0.0 ! cld
	3548	#ifdef ISO
	3549	do ixt = 1, ntraciso
	3550	fxt(ixt,il,i)=0.0
	3551	xtVprecip(ixt,il,i)=0.0
	3552	enddo
	3553	#ifdef DIAGISO
	3554	fq_fluxmasse(il,i)=0.0
	3555	fq_detrainement(il,i)=0.0
	3556	f_detrainement(il,i)=0.0
	3557	q_detrainement(il,i)=0.0
	3558	fq_evapprecip(il,i)=0.0
	3559	fq_ddft(il,i)=0.0
	3560	do ixt = 1, niso
	3561	fxt_fluxmasse(ixt,il,i)=0.0
	3562	fxt_detrainement(ixt,il,i)=0.0
	3563	xt_detrainement(ixt,il,i)=0.0
	3564	fxt_evapprecip(ixt,il,i)=0.0
	3565	fxt_ddft(ixt,il,i)=0.0
	3566	enddo
	3567	#endif
	3568	#endif
	3569	END DO
	3570	END DO
	3571
	3572	! do j=1,ntra
	3573	! do i=1,nd
	3574	! do il=1,ncum
	3575	! ftra(il,i,j)=0.0
	3576	! enddo
	3577	! enddo
	3578	! enddo
	3579
	3580	DO i = 1, nl
	3581	DO il = 1, ncum
	3582	lvcp(il, i) = lv(il, i)/cpn(il, i)
	3583	END DO
	3584	END DO
	3585
	3586
	3587
	3588	! * calculate surface precipitation in mm/day *
	3589
	3590	DO il = 1, ncum
	3591	IF (ep(il,inb(il))>=0.0001) THEN
	3592	IF (cvflag_grav) THEN
	3593	precip(il) = wt(il, 1)sigdwater(il, 1)86400.1000./(rowl*grav)
	3594
	3595	#ifdef ISO
	3596	do ixt = 1, ntraciso
	3597	xtprecip(ixt,il)=wt(il,1)sigdxtwater(ixt,il,1) &
	3598	& 86400.1000./(rowl*grav) ! en mm/jour
	3599	enddo
	3600	! cam verif
	3601	#ifdef ISOVERIF
	3602	if (iso_eau.gt.0) then
	3603	! write(,) 'cv30_yield 2952: '//
	3604	! : 'il,water(il,1),xtwater(iso_eau,il,1)='
	3605	! : ,il,water(il,1),xtwater(iso_eau,il,1)
	3606	call iso_verif_egalite_choix(xtwater(iso_eau,il,1), &
	3607	& water(il,1),'cv30_routines 2959', &
	3608	& errmax,errmaxrel)
	3609	!Rq: wt(il,1)sigd86400.1000./(rowlgrav)=3964.6565
	3610	! -> on auatorise 3e3 fois plus d'erreur dans precip
	3611	call iso_verif_egalite_choix(xtprecip(iso_eau,il), &
	3612	& precip(il),'cv30_routines 3138', &
	3613	& errmax*4e3,errmaxrel)
	3614	endif !if (iso_eau.gt.0) then
	3615	#ifdef ISOTRAC
	3616	call iso_verif_traceur(xtwater(1,il,1), &
	3617	& 'cv30_routine 3146')
	3618	if (iso_verif_traceur_choix_nostop(xtprecip(1,il), &
	3619	& 'cv30_routine 3147',errmax*1e2, &
	3620	& errmaxrel,ridicule_trac,deltalimtrac).eq.1) then
	3621	write(,) 'il,inb(il)=',il,inb(il)
	3622	write(,) 'xtwater(:,il,1)=',xtwater(:,il,1)
	3623	write(,) 'xtprecip(:,il)=',xtprecip(:,il)
	3624	write(,) 'fac=',wt(il,1)sigd86400.1000./(rowlgrav)
	3625	stop
	3626	endif
	3627	#endif
	3628	#endif
	3629	! end cam verif
	3630	#endif
	3631	ELSE
	3632	precip(il) = wt(il, 1)sigdwater(il, 1)*8640.
	3633	#ifdef ISO
	3634	do ixt = 1, ntraciso
	3635	xtprecip(ixt,il)=wt(il,1)sigdxtwater(ixt,il,1)*8640.
	3636	enddo
	3637	! cam verif
	3638	#ifdef ISOVERIF
	3639	if (iso_eau.gt.0) then
	3640	call iso_verif_egalite_choix(xtprecip(iso_eau,il), &
	3641	& precip(il),'cv30_routines 3139', &
	3642	& errmax,errmaxrel)
	3643	endif !if (iso_eau.gt.0) then
	3644	#ifdef ISOTRAC
	3645	call iso_verif_traceur(xtprecip(1,il),'cv30_routine 3166')
	3646	#endif
	3647	#endif
	3648	! end cam verif
	3649	#endif
	3650	END IF !IF (cvflag_grav) THEN
	3651	END IF !IF (cvflag_grav) THEN
	3652	END DO
	3653
	3654	! *** CALCULATE VERTICAL PROFILE OF PRECIPITATIONs IN kg/m2/s ===
	3655
	3656	! MAF rajout pour lessivage
	3657	DO k = 1, nl
	3658	DO il = 1, ncum
	3659	IF (k<=inb(il)) THEN
	3660	IF (cvflag_grav) THEN
	3661	vprecip(il, k) = wt(il, k)sigdwater(il, k)/grav
	3662	#ifdef ISO
	3663	do ixt=1,ntraciso
	3664	xtVPrecip(ixt,il,k) = wt(il,k)*sigd &
	3665	& *xtwater(ixt,il,k)/grav
	3666	enddo
	3667	#endif
	3668	ELSE
	3669	vprecip(il, k) = wt(il, k)sigdwater(il, k)/10.
	3670	#ifdef ISO
	3671	do ixt=1,ntraciso
	3672	xtVPrecip(ixt,il,k) = wt(il,k)*sigd &
	3673	& *xtwater(ixt,il,k)/10.0
	3674	enddo
	3675	#endif
	3676	END IF
	3677	END IF
	3678	END DO
	3679	END DO
	3680
	3681
	3682	! * Calculate downdraft velocity scale *
	3683	! * NE PAS UTILISER POUR L'INSTANT *
	3684
	3685	! ! do il=1,ncum
	3686	! ! wd(il)=betadabs(mp(il,icb(il)))0.01rrdt(il,icb(il))
	3687	! ! : /(sigd*p(il,icb(il)))
	3688	! ! enddo
	3689
	3690
	3691	! * calculate tendencies of lowest level potential temperature *
	3692	! * and mixing ratio *
	3693
	3694	DO il = 1, ncum
	3695	work(il) = 1.0/(ph(il,1)-ph(il,2))
	3696	am(il) = 0.0
	3697	END DO
	3698
	3699	DO k = 2, nl
	3700	DO il = 1, ncum
	3701	IF (k<=inb(il)) THEN
	3702	am(il) = am(il) + m(il, k)
	3703	END IF
	3704	END DO
	3705	END DO
	3706
	3707	DO il = 1, ncum
	3708
	3709	! convect3 if((0.1dpinvam).ge.delti)iflag(il)=4
	3710	IF (cvflag_grav) THEN
	3711	IF ((0.01gravwork(il)*am(il))>=delti) iflag(il) = 1 !consist vect
	3712	ft(il, 1) = 0.01gravwork(il)am(il)(t(il,2)-t(il,1)+(gz(il,2)-gz(il, &
	3713	1))/cpn(il,1))
	3714	ELSE
	3715	IF ((0.1work(il)am(il))>=delti) iflag(il) = 1 !consistency vect
	3716	ft(il, 1) = 0.1work(il)am(il)*(t(il,2)-t(il,1)+(gz(il,2)-gz(il, &
	3717	1))/cpn(il,1))
	3718	END IF
	3719
	3720	ft(il, 1) = ft(il, 1) - 0.5lvcp(il, 1)sigd*(evap(il,1)+evap(il,2))
	3721
	3722	IF (cvflag_grav) THEN
	3723	ft(il, 1) = ft(il, 1) - 0.009gravsigdmp(il, 2)t(il, 1)b(il, 1) &
	3724	work(il)
	3725	ELSE
	3726	ft(il, 1) = ft(il, 1) - 0.09sigdmp(il, 2)t(il, 1)b(il, 1)*work(il)
	3727	END IF
	3728
	3729	ft(il, 1) = ft(il, 1) + 0.01sigdwt(il, 1)(cl-cpd)water(il, 2)*(t(il,2 &
	3730	)-t(il,1))*work(il)/cpn(il, 1)
	3731
	3732	IF (cvflag_grav) THEN
	3733	! jyg1 Correction pour mieux conserver l'eau (conformite avec
	3734	! CONVECT4.3)
	3735	! (sb: pour l'instant, on ne fait que le chgt concernant grav, pas
	3736	! evap)
	3737	fr(il, 1) = 0.01gravmp(il, 2)(rp(il,2)-rr(il,1))work(il) + &
	3738	sigd0.5(evap(il,1)+evap(il,2))
	3739	! +tard : +sigd*evap(il,1)
	3740
	3741	fr(il, 1) = fr(il, 1) + 0.01gravam(il)(rr(il,2)-rr(il,1))work(il)
	3742
	3743	#ifdef ISO
	3744	! juste Mp et evap pour l'instant, voir plus bas pour am
	3745	do ixt = 1, ntraciso
	3746	fxt(ixt,il,1)= &
	3747	& 0.01gravmp(il,2)(xtp(ixt,il,2)-xt(ixt,il,1))work(il) &
	3748	& +sigd0.5(xtevap(ixt,il,1)+xtevap(ixt,il,2))
	3749	!c+tard : +sigd*xtevap(ixt,il,1)
	3750	enddo !do ixt = 1, ntraciso ! pour water tagging option 6: pas besoin ici de faire de conversion.
	3751
	3752	#ifdef DIAGISO
	3753	fq_ddft(il,1)=fq_ddft(il,1) &
	3754	& +0.01gravmp(il,2)(rp(il,2)-rr(il,1))work(il)
	3755	fq_evapprecip(il,1)=fq_evapprecip(il,1) &
	3756	& +sigd0.5(evap(il,1)+evap(il,2))
	3757	fq_fluxmasse(il,1)=fq_fluxmasse(il,1) &
	3758	& +0.01gravam(il)(rr(il,2)-rr(il,1))work(il)
	3759	do ixt = 1, ntraciso
	3760	! fxt_fluxmasse(ixt,il,1)=fxt_fluxmasse(ixt,il,1) &
[4050]	3761	! & +0.01gravam(il)(xt(ixt,il,2)-xt(ixt,il,1))work(il) ! deplace
	3762	! plus haut car il existe differents cas
[3927]	3763	fxt_ddft(ixt,il,1)=fxt_ddft(ixt,il,1) &
	3764	& +0.01gravmp(il,2)(xtp(ixt,il,2)-xt(ixt,il,1))work(il)
	3765	fxt_evapprecip(ixt,il,1)=fxt_evapprecip(ixt,il,1) &
	3766	& +sigd0.5(xtevap(ixt,il,1)+xtevap(ixt,il,2))
	3767	enddo
	3768	#endif
	3769
	3770
[4050]	3771	! pour l'ajout de la tendance liee au flux de masse Am, il faut etre
[3927]	3772	! prudent.
	3773	! On a dq1=k(q2-q1) avec k=dt0.01gravam(il)*work(il)
[4050]	3774	! Pour les isotopes, la formule utilisee depuis 2006 et qui avait toujours marche est:
[3927]	3775	! dx1=k*(x2-x1)
[4050]	3776	! Mais on plante dans un cas pathologique en decembre 2017 lors du test
	3777	! d'un cas d'Anne Cozic: les isotopes deviennent negatifs.
[3927]	3778	! C'est un cas pas physique: on perd 99% de la masse de vapeur d'eau!
	3779	! q2=1.01e-3 et q1=1.25e-3 kg/kg
[4050]	3780	! et dq=-1.24e-3: comment est-ce possible qu'un flux venant d'un air a
	3781	! q2= 1.01e-3 asseche q1 jusqu'a 0.01e-3kg/kg!
	3782	! Pour les isotopes, ca donne des x1+dx negatifs.
	3783	! Ce n'est pas physique mais il faut quand meme s'adapter.
	3784	! Pour cela, on considere que d'abord on fait rentrer le flux de masse
[3927]	3785	! descendant, et ensuite seulement on fait sortir le flux de masse
	3786	! sortant.
	3787	! Ainsi, le flux de masse sortant ne modifie pas la composition
	3788	! isotopique de la vapeur d'eau q1.
	3789	! A la fin, on a R=(x1+dx)/(q1+dq)=(x1+kx2)/(q1+kq2)
[4050]	3790	! On verifie que quand k est petit, on tend vers la formulation
[3927]	3791	! habituelle.
[4050]	3792	! Comme on est habitues a la formulation habituelle, qu'elle a fait ses
	3793	! preuves, on la garde sauf dans le cas ou dq/q<-0.9 ou on utilise la
[3927]	3794	! nouvelle formulation.
	3795	! rappel: dq_tmp=0.01gravam(il)(rr(il,2)-rr(il,1))work(il)*delt
[4050]	3796	! Meme avec cette nouvelle foirmulation, on a encore des isotopes
	3797	! negatifs, cette fois a cause des ddfts
	3798	! On considere donc les tendances et serie et non en parallele quand on
[3927]	3799	! calcule R_tmp.
	3800	dq_tmp=0.01gravam(il)(rr(il,2)-rr(il,1))work(il)*delt ! utile ci-dessous
	3801	if ((dq_tmp/rr(il,1).lt.-0.9).and.correction_excess_aberrant) then
[4050]	3802	! nouvelle formulation ou on fait d'abord entrer k*q2 et ensuite
[3927]	3803	! seulement on fait sortir k*q1 sans changement de composition
	3804	! isotopique
	3805	k_tmp=0.01gravam(il)work(il)delt
	3806	dqreste_tmp= 0.01gravmp(il, 2)(rp(il,2)-rr(il,1))work(il)*delt + &
	3807	& sigd0.5(evap(il,1)+evap(il,2))*delt
	3808	do ixt = 1, ntraciso
	3809	dxreste_tmp= 0.01gravmp(il,2)(xtp(ixt,il,2)-xt(ixt,il,1))work(il)*delt &
	3810	& +sigd0.5(xtevap(ixt,il,1)+xtevap(ixt,il,2))*delt
	3811	R_tmp=(xt(ixt,il,1)+dxreste_tmp+k_tmpxt(ixt,il,2))/(rr(il,1)+dqreste_tmp+k_tmprr(il,2))
	3812	dx_tmp=R_tmp*(rr(il,1)+dqreste_tmp+dq_tmp)-(xt(ixt,il,1)+dxreste_tmp)
	3813	fxt(ixt,il,1)=fxt(ixt,il,1) &
	3814	& + dx_tmp/delt
	3815	#ifdef ISOVERIF
	3816	if (ixt.eq.iso_HDO) then
	3817	write(,) 'cv30_routines 3888: il=',il
	3818	write(,) 'dq_tmp,rr(il,1)=',dq_tmp,rr(il,1)
	3819	write(,) 'R_tmp,dx_tmp,delt=',R_tmp,dx_tmp,delt
	3820	write(,) 'xt(ixt,il,1:2)=',xt(ixt,il,1:2)
	3821	write(,) 'rr(il,1:2)=',rr(il,1:2)
	3822	write(,) 'fxt=',dx_tmp/delt
	3823	write(,) 'rr(il,1)+dq_tmp=',rr(il,1)+dq_tmp
	3824	write(,) 'xt(ixt,il,1)+dx_tmp=',xt(ixt,il,1)+dx_tmp
	3825	write(,) 'xt(ixt,il,1)+fxt(ixt,il,1)*delt=', &
	3826	& xt(ixt,il,1)+fxt(ixt,il,1)*delt
	3827	write(,) 'dqreste_tmp,dxreste_tmp=',dqreste_tmp,dxreste_tmp
	3828	write(,) 'formule classique: fxt_Am=',0.01gravam(il)(xt(ixt,il,2)-xt(ixt,il,1))work(il)
	3829	write(,) 'donnerait dxt=',0.01gravam(il)(xt(ixt,il,2)-xt(ixt,il,1))work(il)*delt
	3830	endif !if (ixt.eq.iso_HDO) then
	3831	#endif
	3832	#ifdef DIAGISO
	3833	if (ixt.le.niso) then
	3834	fxt_fluxmasse(ixt,il,1)=fxt_fluxmasse(ixt,il,1) &
	3835	& + dx_tmp/delt
	3836	endif
	3837	#endif
	3838	enddo ! do ixt = 1, ntraciso
	3839	else !if (dq_tmp/rr(il,1).lt.-0.9) then
[4050]	3840	! formulation habituelle qui avait toujours marche de 2006 a
	3841	! decembre 2017.
[3927]	3842	do ixt = 1, ntraciso
	3843	fxt(ixt,il,1)=fxt(ixt,il,1) &
	3844	& +0.01gravam(il)(xt(ixt,il,2)-xt(ixt,il,1))work(il)
	3845	#ifdef DIAGISO
	3846	if (ixt.le.niso) then
	3847	fxt_fluxmasse(ixt,il,1)=fxt_fluxmasse(ixt,il,1) &
	3848	& +0.01gravam(il)(xt(ixt,il,2)-xt(ixt,il,1))work(il)
	3849	endif
	3850	#endif
	3851	enddo !do ixt = 1, ntraciso
	3852	endif !if (dq_tmp/rr(il,1).lt.-0.9) then
	3853
	3854	! cam verif
	3855	#ifdef ISOVERIF
	3856	if (iso_eau.gt.0) then
	3857	call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
	3858	& fr(il,1),'cv30_routines 3251', &
	3859	& errmax,errmaxrel)
	3860	endif !if (iso_eau.gt.0) then
	3861	!write(,) 'il,am(il)=',il,am(il)
	3862	if ((iso_HDO.gt.0).and. &
	3863	& (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
	3864	if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,1) &
	3865	& +deltfxt(iso_HDO,il,1))/(rr(il,1)+deltfr(il,1)), &
	3866	& 'cv30_yield 3125, ddft en 1').eq.1) then
	3867	write(,) 'il,rr(il,1),delt=',il,rr(il,1),delt
	3868	write(,) 'deltaDxt=',deltaD(xt(iso_HDO,il,1)/rr(il,1))
	3869	write(,) 'deltfr(il,1),fr(il,1)=',deltfr(il,1),fr(il,1)
	3870	write(,) 'fxt=',fxt(iso_HDO,il,1)
	3871	write(,) 'fq_ddft(il,1)=',0.01gravmp(il,2)(rp(il,2)-rr(il,1))work(il)
	3872	write(,) 'fq_evapprecip(il,1)=',sigd0.5(evap(il,1)+evap(il,2))
	3873	write(,) 'fq_fluxmasse(il,1)=', 0.01gravam(il)(rr(il,2)-rr(il,1))work(il)
	3874	write(,) 'deltaDfq_ddft=',deltaD((xtp(iso_HDO,il,2)-xt(iso_HDO,il,1))/(rp(il,2)-rr(il,1)))
	3875	write(,) 'deltaDfq_evapprecip=',deltaD((xtevap(iso_HDO,il,1)+xtevap(iso_HDO,il,2))/(evap(il,1)+evap(il,2)))
	3876	write(,) 'deltaDfq_fluxmasse=',deltaD((xt(iso_HDO,il,2)-xt(iso_HDO,il,1))/(rr(il,2)-rr(il,1)))
	3877	write(,) 'rr(il,2),rr(il,1)=',rr(il,2),rr(il,1)
	3878	write(,) 'xt(iso_HDO,il,2),xt(iso_HDO,il,1)',xt(iso_HDO,il,2),xt(iso_HDO,il,1)
	3879	write(,) 'dq_tmp=',dq_tmp
	3880	call abort_physic('cv30_routines','cv30_yield',1)
	3881	endif ! iso_verif_aberrant_enc_nostop
	3882	endif !if (iso_HDO.gt.0) then
	3883	#ifdef ISOTRAC
	3884	call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3417')
	3885	do ixt=1,ntraciso
	3886	xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
	3887	enddo
	3888	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3395',1e-5) &
	3889	& .eq.1) then
	3890	write(,) 'il=',il
	3891	write(,) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
	3892	write(,) 'xt(:,il,1)=' ,xt(:,il,1)
	3893	#ifdef DIAGISO
	3894	write(,) 'fxt_fluxmasse(:,il,1)=',fxt_fluxmasse(:,il,1)
	3895	write(,) 'fxt_ddft(:,il,1)=',fxt_ddft(:,il,1)
	3896	write(,) 'fxt_evapprecip(:,il,1)=', &
	3897	& fxt_evapprecip(:,il,1)
	3898	write(,) 'xt(:,il,2)=',xt(:,il,2)
	3899	write(,) 'xtp(:,il,2)=',xtp(:,il,2)
	3900	write(,) 'xtevap(:,il,1)=',xtevap(:,il,1)
	3901	write(,) 'xtevap(:,il,2)=',xtevap(:,il,2)
	3902	write(,) 'facam,facmp,facev=',0.01gravam(il)*work(il), &
	3903	& 0.01gravmp(il,2)work(il),sigd0.5
	3904	#endif
	3905	! stop
	3906	endif
	3907	#endif
	3908	#endif
	3909	! end cam verif
	3910	#endif
	3911
	3912	fu(il, 1) = fu(il, 1) + 0.01gravwork(il)(mp(il,2)(up(il,2)-u(il, &
	3913	1))+am(il)*(u(il,2)-u(il,1)))
	3914	fv(il, 1) = fv(il, 1) + 0.01gravwork(il)(mp(il,2)(vp(il,2)-v(il, &
	3915	1))+am(il)*(v(il,2)-v(il,1)))
	3916	ELSE ! cvflag_grav
	3917	fr(il, 1) = 0.1mp(il, 2)(rp(il,2)-rr(il,1))*work(il) + &
	3918	sigd0.5(evap(il,1)+evap(il,2))
	3919	fr(il, 1) = fr(il, 1) + 0.1am(il)(rr(il,2)-rr(il,1))*work(il)
	3920
	3921
	3922	#ifdef ISO
	3923	do ixt = 1, ntraciso
	3924	fxt(ixt,il,1)=0.1mp(il,2)(xtp(ixt,il,2)-xt(ixt,il,1))*work(il) &
	3925	& +sigd0.5(xtevap(ixt,il,1)+xtevap(ixt,il,2))
	3926	fxt(ixt,il,1)=fxt(ixt,il,1) &
	3927	& +0.1am(il)(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
	3928	enddo
	3929
	3930	#ifdef DIAGISO
	3931	fq_ddft(il,1)=fq_ddft(il,1) &
	3932	& +0.1mp(il,2)(rp(il,2)-rr(il,1))*work(il)
	3933	fq_evapprecip(il,1)=fq_evapprecip(il,1) &
	3934	& +sigd0.5(evap(il,1)+evap(il,2))
	3935	fq_fluxmasse(il,1)=fq_fluxmasse(il,1) &
	3936	& +0.1am(il)(rr(il,2)-rr(il,1))*work(il)
	3937	do ixt = 1, niso
	3938	fxt_fluxmasse(ixt,il,1)=fxt(ixt,il,1) &
	3939	& +0.1am(il)(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
	3940	fxt_ddft(ixt,il,1)=fxt(ixt,il,1) &
	3941	& +0.1mp(il,2)(xtp(ixt,il,2)-xt(ixt,il,1))*work(il)
	3942	fxt_evapprecip(ixt,il,1)=fxt(ixt,il,1) &
	3943	& +sigd0.5(xtevap(ixt,il,1)+xtevap(ixt,il,2))
	3944	enddo
	3945	#endif
	3946
	3947
	3948	! cam verif
	3949	#ifdef ISOVERIF
	3950	if (iso_eau.gt.0) then
	3951	call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
	3952	& fr(il,1),'cv30_routines 3023', &
	3953	& errmax,errmaxrel)
	3954	endif !if (iso_eau.gt.0) then
	3955	if ((iso_HDO.gt.0).and. &
	3956	& (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
	3957	call iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
	3958	& +delt*fxt(iso_HDO,il,1)) &
	3959	& /(rr(il,1)+delt*fr(il,1)), &
	3960	& 'cv30_yield 3125b, ddft en 1')
	3961	endif !if (iso_HDO.gt.0) then
	3962	#ifdef ISOTRAC
	3963	call iso_verif_traceur_justmass(fxt(1,il,1), &
	3964	& 'cv30_routine 3417')
	3965	do ixt=1,ntraciso
	3966	xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
	3967	enddo
	3968	if (iso_verif_tracpos_choix_nostop(xtnew, &
	3969	& 'cv30_yield 3449',1e-5) &
	3970	& .eq.1) then
	3971	write(,) 'il=',il
	3972	write(,) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
	3973	write(,) 'xt(:,il,1)=' ,xt(:,il,1)
	3974	! stop
	3975	endif
	3976	#endif
	3977	#endif
	3978	! end cam verif
	3979	#endif
	3980	fu(il, 1) = fu(il, 1) + 0.1work(il)(mp(il,2)*(up(il,2)-u(il, &
	3981	1))+am(il)*(u(il,2)-u(il,1)))
	3982	fv(il, 1) = fv(il, 1) + 0.1work(il)(mp(il,2)*(vp(il,2)-v(il, &
	3983	1))+am(il)*(v(il,2)-v(il,1)))
	3984	END IF ! cvflag_grav
	3985
	3986	END DO ! il
	3987
	3988	! do j=1,ntra
	3989	! do il=1,ncum
	3990	! if (cvflag_grav) then
	3991	! ftra(il,1,j)=ftra(il,1,j)+0.01gravwork(il)
	3992	! : (mp(il,2)(trap(il,2,j)-tra(il,1,j))
	3993	! : +am(il)*(tra(il,2,j)-tra(il,1,j)))
	3994	! else
	3995	! ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
	3996	! : (mp(il,2)(trap(il,2,j)-tra(il,1,j))
	3997	! : +am(il)*(tra(il,2,j)-tra(il,1,j)))
	3998	! endif
	3999	! enddo
	4000	! enddo
	4001
	4002	DO j = 2, nl
	4003	DO il = 1, ncum
	4004	IF (j<=inb(il)) THEN
	4005	IF (cvflag_grav) THEN
	4006	fr(il, 1) = fr(il, 1) + 0.01gravwork(il)ment(il, j, 1)(qent(il, &
	4007	j,1)-rr(il,1))
	4008	fu(il, 1) = fu(il, 1) + 0.01gravwork(il)ment(il, j, 1)(uent(il, &
	4009	j,1)-u(il,1))
	4010	fv(il, 1) = fv(il, 1) + 0.01gravwork(il)ment(il, j, 1)(vent(il, &
	4011	j,1)-v(il,1))
	4012
	4013	#ifdef ISO
	4014	do ixt = 1, ntraciso
	4015	fxt(ixt,il,1)=fxt(ixt,il,1) &
	4016	& +0.01gravwork(il)ment(il,j,1)(xtent(ixt,il,j,1)-xt(ixt,il,1))
	4017	enddo
	4018
	4019	#ifdef DIAGISO
	4020	fq_detrainement(il,1)=fq_detrainement(il,1) &
	4021	& +0.01gravwork(il)ment(il,j,1)(qent(il,j,1)-rr(il,1))
	4022	f_detrainement(il,1)=f_detrainement(il,1) &
	4023	& +0.01gravwork(il)*ment(il,j,1)
	4024	q_detrainement(il,1)=q_detrainement(il,1) &
	4025	& +0.01gravwork(il)ment(il,j,1)qent(il,j,1)
	4026	do ixt = 1, niso
	4027	fxt_detrainement(ixt,il,1)=fxt_detrainement(ixt,il,1) &
	4028	& +0.01gravwork(il)ment(il,j,1)(xtent(ixt,il,j,1)-xt(ixt,il,1))
	4029	xt_detrainement(ixt,il,1)=xt_detrainement(ixt,il,1) &
	4030	& +0.01gravwork(il)ment(il,j,1)xtent(ixt,il,j,1)
	4031	enddo
	4032	#endif
	4033
	4034	! cam verif
	4035	#ifdef ISOVERIF
	4036	if (iso_eau.gt.0) then
	4037	call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
	4038	& fr(il,1),'cv30_routines 3251',errmax,errmaxrel)
	4039	endif !if (iso_eau.gt.0) then
	4040	if ((iso_HDO.gt.0).and. &
	4041	& (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
	4042	call iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
	4043	& +deltfxt(iso_HDO,il,1))/(rr(il,1)+deltfr(il,1)), &
	4044	& 'cv30_yield 3127, dtr melanges')
	4045	endif !if (iso_HDO.gt.0) then
	4046	#ifdef ISOTRAC
	4047	call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3417')
	4048	do ixt=1,ntraciso
	4049	xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
	4050	enddo
	4051	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3525',1e-5) &
	4052	& .eq.1) then
	4053	write(,) 'il=',il
	4054	write(,) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
	4055	write(,) 'fac=', 0.01gravwork(il)*ment(il,j,1)
	4056	write(,) 'xt(:,il,1)=' ,xt(:,il,1)
	4057	write(,) 'xtent(:,il,j,1)=' ,xtent(:,il,j,1)
	4058	! stop
	4059	endif
	4060	#endif
	4061	#endif
	4062	! end cam verif
	4063	#endif
	4064
	4065	ELSE ! cvflag_grav
	4066	fr(il, 1) = fr(il, 1) + 0.1work(il)ment(il, j, 1)*(qent(il,j,1)- &
	4067	rr(il,1))
	4068	fu(il, 1) = fu(il, 1) + 0.1work(il)ment(il, j, 1)*(uent(il,j,1)-u &
	4069	(il,1))
	4070	fv(il, 1) = fv(il, 1) + 0.1work(il)ment(il, j, 1)*(vent(il,j,1)-v &
	4071	(il,1))
	4072
	4073	#ifdef ISO
	4074	do ixt = 1, ntraciso
	4075	fxt(ixt,il,1)=fxt(ixt,il,1) &
	4076	& +0.1work(il)ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
	4077	enddo
	4078
	4079	#ifdef DIAGISO
	4080	fq_detrainement(il,1)=fq_detrainement(il,1) &
	4081	& +0.1work(il)ment(il,j,1)*(qent(il,j,1)-rr(il,1))
	4082	f_detrainement(il,1)=f_detrainement(il,1) &
	4083	& +0.1work(il)ment(il,j,1)
	4084	q_detrainement(il,1)=q_detrainement(il,1) &
	4085	& +0.1work(il)ment(il,j,1)*qent(il,j,1)
	4086	do ixt = 1, niso
	4087	fxt_detrainement(ixt,il,1)=fxt_detrainement(ixt,il,1) &
	4088	& +0.1work(il)ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
	4089	xt_detrainement(ixt,il,1)=xt_detrainement(ixt,il,1) &
	4090	& +0.1work(il)ment(il,j,1)*xtent(ixt,il,j,1)
	4091	enddo
	4092	#endif
	4093
	4094	! cam verif
	4095	#ifdef ISOVERIF
	4096	if (iso_eau.gt.0) then
	4097	call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
	4098	& fr(il,1),'cv30_routines 3092',errmax,errmaxrel)
	4099	endif !if (iso_eau.gt.0) then
	4100	if ((iso_HDO.gt.0).and. &
	4101	& (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
	4102	call iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
	4103	& +deltfxt(iso_HDO,il,1))/(rr(il,1)+deltfr(il,1)), &
	4104	& 'cv30_yield 3127b, dtr melanges')
	4105	endif !if (iso_HDO.gt.0) then
	4106	#ifdef ISOTRAC
	4107	call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3462')
	4108	do ixt=1,ntraciso
	4109	xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
	4110	enddo
	4111	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3753',1e-5) &
	4112	& .eq.1) then
	4113	write(,) 'il=',il
	4114	endif
	4115	#endif
	4116	#endif
	4117	! end cam verif
	4118	#endif
	4119
	4120	END IF ! cvflag_grav
	4121	END IF ! j
	4122	END DO
	4123	END DO
	4124
	4125	! do k=1,ntra
	4126	! do j=2,nl
	4127	! do il=1,ncum
	4128	! if (j.le.inb(il)) then
	4129
	4130	! if (cvflag_grav) then
	4131	! ftra(il,1,k)=ftra(il,1,k)+0.01gravwork(il)*ment(il,j,1)
	4132	! : *(traent(il,j,1,k)-tra(il,1,k))
	4133	! else
	4134	! ftra(il,1,k)=ftra(il,1,k)+0.1work(il)ment(il,j,1)
	4135	! : *(traent(il,j,1,k)-tra(il,1,k))
	4136	! endif
	4137
	4138	! endif
	4139	! enddo
	4140	! enddo
	4141	! enddo
	4142
	4143
	4144	! * calculate tendencies of potential temperature and mixing ratio *
	4145	! * at levels above the lowest level *
	4146
	4147	! * first find the net saturated updraft and downdraft mass fluxes *
	4148	! * through each level *
	4149
	4150
	4151	DO i = 2, nl + 1 ! newvecto: mettre nl au lieu nl+1?
	4152
	4153	num1 = 0
	4154	DO il = 1, ncum
	4155	IF (i<=inb(il)) num1 = num1 + 1
	4156	END DO
	4157	IF (num1<=0) GO TO 500
	4158
	4159	CALL zilch(amp1, ncum)
	4160	CALL zilch(ad, ncum)
	4161
	4162	DO k = i + 1, nl + 1
	4163	DO il = 1, ncum
	4164	IF (i<=inb(il) .AND. k<=(inb(il)+1)) THEN
	4165	amp1(il) = amp1(il) + m(il, k)
	4166	END IF
	4167	END DO
	4168	END DO
	4169
	4170	DO k = 1, i
	4171	DO j = i + 1, nl + 1
	4172	DO il = 1, ncum
	4173	IF (i<=inb(il) .AND. j<=(inb(il)+1)) THEN
	4174	amp1(il) = amp1(il) + ment(il, k, j)
	4175	END IF
	4176	END DO
	4177	END DO
	4178	END DO
	4179
	4180	DO k = 1, i - 1
	4181	DO j = i, nl + 1 ! newvecto: nl au lieu nl+1?
	4182	DO il = 1, ncum
	4183	IF (i<=inb(il) .AND. j<=inb(il)) THEN
	4184	ad(il) = ad(il) + ment(il, j, k)
	4185	END IF
	4186	END DO
	4187	END DO
	4188	END DO
	4189
	4190	DO il = 1, ncum
	4191	IF (i<=inb(il)) THEN
	4192	dpinv = 1.0/(ph(il,i)-ph(il,i+1))
	4193	cpinv = 1.0/cpn(il, i)
	4194
	4195	! convect3 if((0.1dpinvamp1).ge.delti)iflag(il)=4
	4196	IF (cvflag_grav) THEN
	4197	IF ((0.01gravdpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
	4198	ELSE
	4199	IF ((0.1dpinvamp1(il))>=delti) iflag(il) = 1 ! vecto
	4200	END IF
	4201
	4202	IF (cvflag_grav) THEN
	4203	ft(il, i) = 0.01gravdpinv(amp1(il)(t(il,i+1)-t(il, &
	4204	i)+(gz(il,i+1)-gz(il,i))cpinv)-ad(il)(t(il,i)-t(il, &
	4205	i-1)+(gz(il,i)-gz(il,i-1))cpinv)) - 0.5sigdlvcp(il, i)(evap( &
	4206	il,i)+evap(il,i+1))
	4207	rat = cpn(il, i-1)*cpinv
	4208	ft(il, i) = ft(il, i) - 0.009gravsigd(mp(il,i+1)t(il,i)*b(il,i) &
	4209	-mp(il,i)t(il,i-1)ratb(il,i-1))dpinv
	4210	ft(il, i) = ft(il, i) + 0.01gravdpinvment(il, i, i)(hp(il,i)-h( &
	4211	il,i)+t(il,i)(cpv-cpd)(rr(il,i)-qent(il,i,i)))*cpinv
	4212	ELSE ! cvflag_grav
	4213	ft(il, i) = 0.1dpinv(amp1(il)*(t(il,i+1)-t(il, &
	4214	i)+(gz(il,i+1)-gz(il,i))cpinv)-ad(il)(t(il,i)-t(il, &
	4215	i-1)+(gz(il,i)-gz(il,i-1))cpinv)) - 0.5sigdlvcp(il, i)(evap( &
	4216	il,i)+evap(il,i+1))
	4217	rat = cpn(il, i-1)*cpinv
	4218	ft(il, i) = ft(il, i) - 0.09sigd(mp(il,i+1)t(il,i)b(il,i)-mp(il &
	4219	,i)t(il,i-1)ratb(il,i-1))dpinv
	4220	ft(il, i) = ft(il, i) + 0.1dpinvment(il, i, i)*(hp(il,i)-h(il,i)+ &
	4221	t(il,i)(cpv-cpd)(rr(il,i)-qent(il,i,i)))*cpinv
	4222	END IF ! cvflag_grav
	4223
	4224
	4225	ft(il, i) = ft(il, i) + 0.01sigdwt(il, i)(cl-cpd)water(il, i+1)*( &
	4226	t(il,i+1)-t(il,i))dpinvcpinv
	4227
	4228	IF (cvflag_grav) THEN
	4229	fr(il, i) = 0.01gravdpinv(amp1(il)(rr(il,i+1)-rr(il, &
	4230	i))-ad(il)*(rr(il,i)-rr(il,i-1)))
	4231	fu(il, i) = fu(il, i) + 0.01gravdpinv(amp1(il)(u(il,i+1)-u(il, &
	4232	i))-ad(il)*(u(il,i)-u(il,i-1)))
	4233	fv(il, i) = fv(il, i) + 0.01gravdpinv(amp1(il)(v(il,i+1)-v(il, &
	4234	i))-ad(il)*(v(il,i)-v(il,i-1)))
	4235
	4236	#ifdef ISO
	4237	#ifdef DIAGISO
	4238	fq_fluxmasse(il,i)=fq_fluxmasse(il,i) &
	4239	& +0.01gravdpinv(amp1(il)(rr(il,i+1)-rr(il,i)) &
	4240	& -ad(il)*(rr(il,i)-rr(il,i-1)))
	4241	! modif 2 fev: pour avoir subsidence compensatoire totale, on retranche
	4242	! ad.
	4243	#endif
[4050]	4244	! ici, on separe 2 cas, pour eviter le cas pathologique decrit plus haut
	4245	! pour la tendance liee a Am en i=1, qui peut conduire a des isotopes
	4246	! negatifs dans les cas ou les flux de masse soustrait plus de 90% de la
	4247	! vapeur de la couche. Voir plus haut le detail des equations.
	4248	! La difference ici est qu'on considere les flux de masse amp1 et ad en
	4249	! meme temps.
[3927]	4250	dq_tmp= 0.01gravdpinv(amp1(il)(rr(il,i+1)-rr(il,i)) &
	4251	& -ad(il)(rr(il,i)-rr(il,i-1)))delt
[4050]	4252	! c'est equivalent a dqi= kamp1qip1+kadqim1-(kamp1+kad)*qi
[3927]	4253	if ((dq_tmp/rr(il,i).lt.-0.9).and.correction_excess_aberrant) then
	4254	! nouvelle formulation
	4255	k_tmp=0.01gravdpinvamp1(il)delt
	4256	kad_tmp=0.01gravdpinvad(il)delt
	4257	do ixt = 1, ntraciso
	4258	R_tmp=(xt(ixt,il,i)+k_tmpxt(ixt,il,i+1)+kad_tmpxt(ixt,il,i-1)) &
	4259	& /(rr(il,i)+k_tmprr(il,i+1)+kad_tmprr(il,i-1))
	4260	dx_tmp= R_tmp*( rr(il,i)+ dq_tmp)-xt(ixt,il,i)
	4261	fxt(ixt,il,i)= dx_tmp/delt
	4262	#ifdef ISOVERIF
	4263	if ((ixt.eq.iso_HDO).or.(ixt.eq.iso_eau)) then
	4264	write(,) 'cv30_routines 4367: il,i,ixt=',il,i,ixt
	4265	write(,) 'dq_tmp,rr(il,i)=',dq_tmp,rr(il,i)
	4266	write(,) 'R_tmp,dx_tmp,delt=',R_tmp,dx_tmp,delt
	4267	write(,) 'amp1(il),ad(il)=',amp1(il),ad(il)
	4268	write(,) 'xt(ixt,il,i-1:i+1)=',xt(ixt,il,i-1:i+1)
	4269	write(,) 'rr(il,i-1:i+1)=',rr(il,i-1:i+1)
	4270	write(,) 'fxt=',dx_tmp/delt
	4271	write(,) 'rr(il,i)+dq_tmp=',rr(il,1)+dq_tmp
	4272	write(,) 'xt(ixt,il,i)+dx_tmp=',xt(ixt,il,i)+dx_tmp
	4273	write(,) 'xt(ixt,il,i)+fxt(ixt,il,i)*delt=', &
	4274	& xt(ixt,il,i)+fxt(ixt,il,i)*delt
	4275	write(,) 'fxt(:,il,i)=',fxt(:,il,i)
	4276	endif !if (ixt.eq.iso_HDO) then
	4277	#endif
	4278	enddo ! do ixt = 1, ntraciso
	4279	#ifdef DIAGISO
	4280	do ixt = 1, niso
	4281	fxt_fluxmasse(ixt,il,i)=fxt(ixt,il,i)
	4282	enddo
	4283	#endif
	4284	else !if (dq_tmp/rr(il,i).lt.-0.9) then
	4285	! ancienne formulation
	4286	do ixt = 1, ntraciso
	4287	fxt(ixt,il,i)= &
	4288	& 0.01gravdpinv(amp1(il)(xt(ixt,il,i+1)-xt(ixt,il,i)) &
	4289	& -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
	4290	enddo
	4291	#ifdef DIAGISO
	4292	do ixt = 1, niso
	4293	fxt_fluxmasse(ixt,il,i)=fxt_fluxmasse(ixt,il,i)+ &
	4294	& 0.01gravdpinv(amp1(il)(xt(ixt,il,i+1)-xt(ixt,il,i)) &
	4295	& -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
	4296	enddo
	4297	#endif
	4298	endif !if (dq_tmp/rr(il,i).lt.-0.9) then
	4299
	4300
	4301	! cam verif
	4302	#ifdef ISOVERIF
	4303	if (iso_eau.gt.0) then
	4304	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
	4305	& fr(il,i),'cv30_routines 3226',errmax,errmaxrel)
	4306	endif !if (iso_eau.gt.0) then
	4307	do ixt=1,niso
	4308	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3229')
	4309	enddo
	4310	if ((iso_HDO.gt.0).and. &
	4311	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	4312	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
	4313	& +delt*fxt(iso_HDO,il,i)) &
	4314	& /(rr(il,i)+delt*fr(il,i)), &
	4315	& 'cv30_yield 3384, flux masse')
	4316	endif !if (iso_HDO.gt.0) then
	4317	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
	4318	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	4319	call iso_verif_O18_aberrant( &
	4320	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
	4321	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
	4322	& 'cv30_yield 3384,O18, flux masse')
	4323	endif !if (iso_HDO.gt.0) then
	4324	#ifdef ISOTRAC
	4325	call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3626')
	4326	do ixt=1,ntraciso
	4327	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
	4328	enddo
	4329	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3727',1e-5) &
	4330	& .eq.1) then
	4331	write(,) 'il,i=',il,i
	4332	write(,) 'fxt(:,il,i)=',fxt(:,il,i)
	4333	write(,) 'amp1(il),ad(il),fac=', &
	4334	& amp1(il),ad(il),0.01gravdpinv
	4335	write(,) 'xt(:,il,i+1)=' ,xt(:,il,i+1)
	4336	write(,) 'xt(:,il,i)=' ,xt(:,il,i)
	4337	write(,) 'xt(:,il,i-1)=' ,xt(:,il,i-1)
	4338	! stop
	4339	endif
	4340	#endif
	4341	#endif
	4342	! end cam verif
	4343	#endif
	4344	ELSE ! cvflag_grav
	4345	fr(il, i) = 0.1dpinv(amp1(il)*(rr(il,i+1)-rr(il, &
	4346	i))-ad(il)*(rr(il,i)-rr(il,i-1)))
	4347	fu(il, i) = fu(il, i) + 0.1dpinv(amp1(il)*(u(il,i+1)-u(il, &
	4348	i))-ad(il)*(u(il,i)-u(il,i-1)))
	4349	fv(il, i) = fv(il, i) + 0.1dpinv(amp1(il)*(v(il,i+1)-v(il, &
	4350	i))-ad(il)*(v(il,i)-v(il,i-1)))
	4351
	4352	#ifdef ISO
	4353	do ixt = 1, ntraciso
	4354	fxt(ixt,il,i)= &
	4355	& 0.1dpinv(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
	4356	& -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
	4357	enddo
	4358
	4359	#ifdef DIAGISO
	4360	fq_fluxmasse(il,i)=fq_fluxmasse(il,i) &
	4361	& +0.1dpinv(amp1(il)*(rr(il,i+1)-rr(il,i)) &
	4362	& -ad(il)*(rr(il,i)-rr(il,i-1)))
	4363	do ixt = 1, niso
	4364	fxt_fluxmasse(ixt,il,i)=fxt_fluxmasse(ixt,il,i)+ &
	4365	& 0.1dpinv(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
	4366	& -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
	4367	enddo
	4368	#endif
	4369
	4370	! cam verif
	4371	#ifdef ISOVERIF
	4372	if (iso_eau.gt.0) then
	4373	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
	4374	& fr(il,i),'cv30_routines 3252',errmax,errmaxrel)
	4375	endif !if (iso_eau.gt.0) then
	4376	do ixt=1,niso
	4377	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3229')
	4378	enddo
	4379	! correction 21 oct 2008
	4380	if ((iso_HDO.gt.0).and. &
	4381	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	4382	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
	4383	& +deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
	4384	& 'cv30_yield 3384b flux masse')
	4385	if (iso_O18.gt.0) then
	4386	call iso_verif_O18_aberrant( &
	4387	& (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
	4388	& /(rr(il,i)+delt*fr(il,i)), &
	4389	& (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
	4390	& /(rr(il,i)+delt*fr(il,i)), &
	4391	& 'cv30_yield 3384bO18 flux masse')
	4392	endif !if (iso_O18.gt.0) then
	4393	endif !if (iso_HDO.gt.0) then
	4394	#ifdef ISOTRAC
	4395	call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3674')
	4396	do ixt=1,ntraciso
	4397	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
	4398	enddo
	4399	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3775',1e-5) &
	4400	& .eq.1) then
	4401	write(,) 'il,i=',il,i
	4402	endif
	4403	#endif
	4404	#endif
	4405	! end cam verif
	4406	#endif
	4407	END IF ! cvflag_grav
	4408
	4409	END IF ! i
	4410	END DO
	4411
	4412	! do k=1,ntra
	4413	! do il=1,ncum
	4414	! if (i.le.inb(il)) then
	4415	! dpinv=1.0/(ph(il,i)-ph(il,i+1))
	4416	! cpinv=1.0/cpn(il,i)
	4417	! if (cvflag_grav) then
	4418	! ftra(il,i,k)=ftra(il,i,k)+0.01gravdpinv
	4419	! : (amp1(il)(tra(il,i+1,k)-tra(il,i,k))
	4420	! : -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
	4421	! else
	4422	! ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
	4423	! : (amp1(il)(tra(il,i+1,k)-tra(il,i,k))
	4424	! : -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
	4425	! endif
	4426	! endif
	4427	! enddo
	4428	! enddo
	4429
	4430	DO k = 1, i - 1
	4431	DO il = 1, ncum
	4432	IF (i<=inb(il)) THEN
	4433	dpinv = 1.0/(ph(il,i)-ph(il,i+1))
	4434	cpinv = 1.0/cpn(il, i)
	4435
	4436	awat = elij(il, k, i) - (1.-ep(il,i))*clw(il, i)
	4437	awat = amax1(awat, 0.0)
	4438
	4439	#ifdef ISO
	4440	! on change le traitement de cette ligne le 8 mai 2009:
	4441	! avant, on avait: xtawat=xtelij(il,k,i)-(1.-xtep(il,i))*xtclw(il,i)
[4050]	4442	! c'est a dire que Rawat=Relij+(1-ep)clw/awat(Relij-Rclw)
	4443	! si Relij!=Rclw, alors un fractionnement isotopique non physique etait
[3927]	4444	! introduit.
[4050]	4445	! En fait, awat represente le surplus de condensat dans le melange par
	4446	! rapport a celui restant dans la colonne adiabatique
	4447	! ce surplus a la meme compo que le elij, sans fractionnement.
	4448	! d'ou le nouveau traitement ci-dessous.
[3927]	4449	if (elij(il,k,i).gt.0.0) then
	4450	do ixt = 1, ntraciso
	4451	xtawat(ixt)=awat*(xtelij(ixt,il,k,i)/elij(il,k,i))
[4050]	4452	! xtawat(ixt)=amax1(xtawat(ixt),0.0) ! pas necessaire
[3927]	4453	enddo
	4454	else !if (elij(il,k,i).gt.0.0) then
	4455	! normalement, si elij(il,k,i)<=0, alors awat=0
[4050]	4456	! on le verifie. Si c'est vrai -> xtawat=0 aussi
[3927]	4457	#ifdef ISOVERIF
	4458	call iso_verif_egalite(awat,0.0,'cv30_yield 3779')
	4459	#endif
	4460	do ixt = 1, ntraciso
	4461	xtawat(ixt)=0.0
	4462	enddo
	4463	endif
	4464
	4465	! cam verif
	4466	#ifdef ISOVERIF
	4467	if (iso_eau.gt.0) then
	4468	call iso_verif_egalite_choix(xtawat(iso_eau), &
	4469	& awat,'cv30_routines 3301',errmax,errmaxrel)
	4470	endif !if (iso_eau.gt.0) then
	4471	#ifdef ISOTRAC
	4472	call iso_verif_traceur_justmass(xtawat(1),'cv30_routine 3729')
	4473	#endif
	4474	#endif
	4475	! end cam verif
	4476	#endif
	4477
	4478	IF (cvflag_grav) THEN
	4479	fr(il, i) = fr(il, i) + 0.01gravdpinvment(il, k, i)(qent(il,k &
	4480	,i)-awat-rr(il,i))
	4481	fu(il, i) = fu(il, i) + 0.01gravdpinvment(il, k, i)(uent(il,k &
	4482	,i)-u(il,i))
	4483	fv(il, i) = fv(il, i) + 0.01gravdpinvment(il, k, i)(vent(il,k &
	4484	,i)-v(il,i))
	4485
	4486	#ifdef ISO
	4487	do ixt = 1, ntraciso
	4488	fxt(ixt,il,i)=fxt(ixt,il,i) &
	4489	& +0.01gravdpinv*ment(il,k,i) &
	4490	& *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
	4491	enddo
	4492
	4493	#ifdef DIAGISO
	4494	fq_detrainement(il,i)=fq_detrainement(il,i) &
	4495	& +0.01gravdpinv*ment(il,k,i) &
	4496	& *(qent(il,k,i)-awat-rr(il,i))
	4497	f_detrainement(il,i)=f_detrainement(il,i)&
	4498	& +0.01gravdpinv*ment(il,k,i)
	4499	q_detrainement(il,i)=q_detrainement(il,i) &
	4500	& +0.01gravdpinvment(il,k,i)qent(il,k,i)
	4501	do ixt = 1, niso
	4502	fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
	4503	& +0.01gravdpinv*ment(il,k,i) &
	4504	& *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
	4505	xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
	4506	& +0.01gravdpinvment(il,k,i)xtent(ixt,il,k,i)
	4507	enddo
	4508	#endif
	4509	! cam verif
	4510	#ifdef ISOVERIF
	4511	if (iso_eau.gt.0) then
	4512	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
	4513	& fr(il,i),'cv30_routines 3325',errmax,errmaxrel)
	4514	endif !if (iso_eau.gt.0) then
	4515	do ixt=1,niso
	4516	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3328')
	4517	enddo
	4518	if ((iso_HDO.gt.0).and. &
	4519	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	4520	if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
	4521	& +delt*fxt(iso_HDO,il,i)) &
	4522	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3396a, dtr mels') &
	4523	& .eq.1) then
	4524	write(,) 'il,k,i=',il,k,i
	4525	write(,) 'rr,delt,fr=',rr(il,i),delt,fr(il,i)
	4526	write(,) 'frnew=',0.01gravdpinvment(il, k, i)(qent(il,k,i)-awat-rr(il,i))
	4527	write(,) 'frold=',fr(il,i)-0.01gravdpinvment(il, k, i)(qent(il,k,i)-awat-rr(il,i))
	4528	write(,) 'deltaDfrnew=',deltaD((xtent(iso_HDO,il,k,i)-xtawat(iso_HDO)-xt(iso_HDO,il,i)) &
	4529	/(qent(il,k,i)-awat-rr(il,i)))
	4530	write(,) 'deltaDfrold=',deltaD((fxt(iso_HDO,il,i) &
	4531	-0.01gravdpinvment(il, k, i)(xtent(iso_HDO,il,k,i)-xtawat(iso_HDO)-xt(iso_HDO,il,i))) &
	4532	/(fr(il,i)-0.01gravdpinvment(il, k, i)(qent(il,k,i)-awat-rr(il,i))))
	4533	write(,) 'q+=',rr(il,i)+delt*fr(il,i)
	4534	write(,) 'qent,awat=',qent(il,k,i),awat
	4535	write(,) 'elij,clw,ep=',elij(il,k,i),clw(il,i),ep(il,i)
	4536	write(,) 'deltaDfr=',deltaD(fxt(iso_hdo,il,i)/fr(il,i))
	4537	write(,) 'deltaDrr=',deltaD(xt(iso_hdo,il,i)/rr(il,i))
	4538	write(,) 'deltaDqent=',deltaD(xtent(iso_hdo,il,k,i) &
	4539	& /qent(il,k,i))
	4540	write(,) 'deltaDqent-awat=',deltaD((xtent(iso_hdo,il,k,i)-xtawat(iso_HDO)) &
	4541	& /(qent(il,k,i)-awat))
	4542	write(,) 'deltaDawat=',deltaD(xtawat(iso_hdo)/awat)
	4543	write(,) 'deltaDclw=',deltaD(xtclw(iso_hdo,il,i)/clw(il,i))
	4544	! stop
	4545	endif
	4546	if (iso_O18.gt.0) then
	4547	call iso_verif_O18_aberrant( &
	4548	& (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
	4549	& /(rr(il,i)+delt*fr(il,i)), &
	4550	& (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
	4551	& /(rr(il,i)+delt*fr(il,i)), &
	4552	& 'cv30_yield 3396aO18, dtr mels')
	4553	endif !if (iso_O18.gt.0) then
	4554	endif !if (iso_HDO.gt.0) then
	4555	#ifdef ISOTRAC
	4556	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3784')
	4557	do ixt=1,ntraciso
	4558	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
	4559	enddo
	4560	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3905',1e-5) &
	4561	& .eq.1) then
	4562	write(,) 'il,i=',il,i
	4563	endif
	4564	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 3905',1e-5)
	4565	#endif
	4566	#endif
	4567	#endif
	4568	ELSE ! cvflag_grav
	4569	fr(il, i) = fr(il, i) + 0.1dpinvment(il, k, i)*(qent(il,k,i)- &
	4570	awat-rr(il,i))
	4571	fu(il, i) = fu(il, i) + 0.01gravdpinvment(il, k, i)(uent(il,k &
	4572	,i)-u(il,i))
	4573	fv(il, i) = fv(il, i) + 0.1dpinvment(il, k, i)*(vent(il,k,i)-v( &
	4574	il,i))
	4575
	4576	#ifdef ISO
	4577	do ixt = 1, ntraciso
	4578	fxt(ixt,il,i)=fxt(ixt,il,i) &
	4579	& +0.1dpinvment(il,k,i) &
	4580	& *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
	4581	enddo
	4582
	4583	#ifdef DIAGISO
	4584	fq_detrainement(il,i)=fq_detrainement(il,i) &
	4585	& +0.1dpinvment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
	4586	f_detrainement(il,i)=f_detrainement(il,i) &
	4587	& +0.1dpinvment(il,k,i)
	4588	q_detrainement(il,i)=q_detrainement(il,i) &
	4589	& +0.1dpinvment(il,k,i)*qent(il,k,i)
	4590	do ixt = 1, niso
	4591	fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
	4592	& +0.1dpinvment(il,k,i) &
	4593	& *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
	4594	xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
	4595	& +0.1dpinvment(il,k,i)*xtent(ixt,il,k,i)
	4596	enddo
	4597	#endif
	4598
	4599	! cam verif
	4600	#ifdef ISOVERIF
	4601	if (iso_eau.gt.0) then
	4602	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
	4603	& fr(il,i),'cv30_routines 3350',errmax,errmaxrel)
	4604	endif !if (iso_eau.gt.0) then
	4605	do ixt=1,niso
	4606	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3353')
	4607	enddo
	4608	if ((iso_HDO.gt.0).and. &
	4609	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	4610	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
	4611	& +delt*fxt(iso_HDO,il,i)) &
	4612	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3396b, dtr mels')
	4613	endif !if (iso_HDO.gt.0) then
	4614	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
	4615	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	4616	call iso_verif_O18_aberrant( &
	4617	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
	4618	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
	4619	& 'cv30_yield 3396b,O18, dtr mels')
	4620	endif !if (iso_HDO.gt.0) then
	4621	#ifdef ISOTRAC
	4622	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3828')
	4623	do ixt=1,ntraciso
	4624	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
	4625	enddo
	4626	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3949',1e-5) &
	4627	& .eq.1) then
	4628	write(,) 'il,i=',il,i
	4629	endif
	4630	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 3949',1e-5)
	4631	#endif
	4632	#endif
	4633	! end cam verif
	4634	#endif
	4635
	4636	END IF ! cvflag_grav
	4637
	4638	! (saturated updrafts resulting from mixing) ! cld
	4639	qcond(il, i) = qcond(il, i) + (elij(il,k,i)-awat) ! cld
	4640	nqcond(il, i) = nqcond(il, i) + 1. ! cld
	4641	END IF ! i
	4642	END DO
	4643	END DO
	4644
	4645	! do j=1,ntra
	4646	! do k=1,i-1
	4647	! do il=1,ncum
	4648	! if (i.le.inb(il)) then
	4649	! dpinv=1.0/(ph(il,i)-ph(il,i+1))
	4650	! cpinv=1.0/cpn(il,i)
	4651	! if (cvflag_grav) then
	4652	! ftra(il,i,j)=ftra(il,i,j)+0.01gravdpinv*ment(il,k,i)
	4653	! : *(traent(il,k,i,j)-tra(il,i,j))
	4654	! else
	4655	! ftra(il,i,j)=ftra(il,i,j)+0.1dpinvment(il,k,i)
	4656	! : *(traent(il,k,i,j)-tra(il,i,j))
	4657	! endif
	4658	! endif
	4659	! enddo
	4660	! enddo
	4661	! enddo
	4662
	4663	DO k = i, nl + 1
	4664	DO il = 1, ncum
	4665	IF (i<=inb(il) .AND. k<=inb(il)) THEN
	4666	dpinv = 1.0/(ph(il,i)-ph(il,i+1))
	4667	cpinv = 1.0/cpn(il, i)
	4668
	4669	IF (cvflag_grav) THEN
	4670	fr(il, i) = fr(il, i) + 0.01gravdpinvment(il, k, i)(qent(il,k &
	4671	,i)-rr(il,i))
	4672	fu(il, i) = fu(il, i) + 0.01gravdpinvment(il, k, i)(uent(il,k &
	4673	,i)-u(il,i))
	4674	fv(il, i) = fv(il, i) + 0.01gravdpinvment(il, k, i)(vent(il,k &
	4675	,i)-v(il,i))
	4676	#ifdef ISO
	4677	do ixt = 1, ntraciso
	4678	fxt(ixt,il,i)=fxt(ixt,il,i) &
	4679	& +0.01gravdpinvment(il,k,i)(xtent(ixt,il,k,i)-xt(ixt,il,i))
	4680	enddo
	4681
	4682	#ifdef DIAGISO
	4683	fq_detrainement(il,i)=fq_detrainement(il,i) &
	4684	& +0.01gravdpinvment(il,k,i)(qent(il,k,i)-rr(il,i))
	4685	f_detrainement(il,i)=f_detrainement(il,i) &
	4686	& +0.01gravdpinv*ment(il,k,i)
	4687	q_detrainement(il,i)=q_detrainement(il,i) &
	4688	& +0.01gravdpinvment(il,k,i)qent(il,k,i)
	4689	do ixt = 1, niso
	4690	fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
	4691	& +0.01gravdpinvment(il,k,i)(xtent(ixt,il,k,i)-xt(ixt,il,i))
	4692	xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
	4693	& +0.01gravdpinvment(il,k,i)xtent(ixt,il,k,i)
	4694	enddo
	4695	#endif
	4696
	4697	! cam verif
	4698	#ifdef ISOVERIF
	4699	if ((il.eq.1636).and.(i.eq.9)) then
	4700	write(,) 'cv30 4785: on ajoute le dtr ici:'
	4701	write(,) 'M=',0.01gravdpinv*ment(il, k, i)
	4702	write(,) 'q,qe=',rr(il,i),qent(il,k,i)
	4703	bx=0.01gravdpinvment(il,k,i)(qent(il,k,i)-rr(il,i))
	4704	do ixt=1,niso
	4705	xtbx(ixt)=0.01gravdpinvment(il,k,i)(xtent(ixt,il,k,i)-xt(ixt,il,i))
	4706	enddo
	4707	endif
	4708	do ixt=1,niso
	4709	call iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 4351')
	4710	enddo
	4711	#endif
	4712	#ifdef ISOVERIF
	4713	if (iso_eau.gt.0) then
	4714	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
	4715	& fr(il,i),'cv30_routines 3408',errmax,errmaxrel)
	4716	endif !if (iso_eau.gt.0) then
	4717	do ixt=1,niso
	4718	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3411')
	4719	enddo
	4720	if (1.eq.0) then
	4721	if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
	4722	if (iso_verif_aberrant_enc_nostop( &
	4723	& fxt(iso_HDO,il,i)/fr(il,i), &
	4724	& 'cv30_yield 3572, dtr mels').eq.1) then
	4725	write(,) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
	4726	write(,) 'fr(il,i)=',fr(il,i)
	4727	! if (fr(il,i).gt.ridicule*1e5) then
	4728	! stop
	4729	! endif
	4730	endif
	4731	endif !if (iso_HDO.gt.0) then
	4732	endif !if (1.eq.0) then
	4733	if ((iso_HDO.gt.0).and. &
	4734	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	4735	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
	4736	& +delt*fxt(iso_HDO,il,i)) &
	4737	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3605, dtr mels')
	4738	if (iso_O18.gt.0) then
	4739	call iso_verif_O18_aberrant( &
	4740	& (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
	4741	& /(rr(il,i)+delt*fr(il,i)), &
	4742	& (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
	4743	& /(rr(il,i)+delt*fr(il,i)), &
	4744	& 'cv30_yield 3605O18, dtr mels')
	4745	if ((il.eq.1636).and.(i.eq.9)) then
	4746	call iso_verif_O18_aberrant( &
	4747	& (xt(iso_HDO,il,i)+delt*(fxt(iso_HDO,il,i)-xtbx(iso_HDO))) &
	4748	& /(rr(il,i)+delt*(fr(il,i)-bx)), &
	4749	& (xt(iso_O18,il,i)+delt*(fxt(iso_O18,il,i)-xtbx(iso_O18))) &
	4750	& /(rr(il,i)+delt*(fr(il,i)-bx)), &
	4751	& 'cv30_yield 3605O18_nobx, dtr mels')
	4752	endif !if ((il.eq.1636).and.(i.eq.9)) then
	4753	endif !if (iso_O18.gt.0) then
	4754	endif !if (iso_HDO.gt.0) then
	4755	#ifdef ISOTRAC
	4756	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3921')
	4757	do ixt=1,ntraciso
	4758	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
	4759	enddo
	4760	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4036',1e-5) &
	4761	& .eq.1) then
	4762	write(,) 'il,i=',il,i
	4763	endif
	4764	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 4036',1e-5)
	4765	#endif
	4766	#endif
	4767	! end cam verif
	4768	#endif
	4769	ELSE ! cvflag_grav
	4770	fr(il, i) = fr(il, i) + 0.1dpinvment(il, k, i)*(qent(il,k,i)-rr &
	4771	(il,i))
	4772	fu(il, i) = fu(il, i) + 0.1dpinvment(il, k, i)*(uent(il,k,i)-u( &
	4773	il,i))
	4774	fv(il, i) = fv(il, i) + 0.1dpinvment(il, k, i)*(vent(il,k,i)-v( &
	4775	il,i))
	4776
	4777	#ifdef ISO
	4778	do ixt = 1, ntraciso
	4779	fxt(ixt,il,i)=fxt(ixt,il,i) &
	4780	& +0.1dpinvment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
	4781	enddo
	4782
	4783	#ifdef DIAGISO
	4784	fq_detrainement(il,i)=fq_detrainement(il,i) &
	4785	& +0.1dpinvment(il,k,i)*(qent(il,k,i)-rr(il,i))
	4786	f_detrainement(il,i)=f_detrainement(il,i) &
	4787	& +0.1dpinvment(il,k,i)
	4788	q_detrainement(il,i)=q_detrainement(il,i) &
	4789	& +0.1dpinvment(il,k,i)*qent(il,k,i)
	4790	do ixt = 1, niso
	4791	fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
	4792	& +0.1dpinvment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
	4793	xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
	4794	& +0.1dpinvment(il,k,i)*xtent(ixt,il,k,i)
	4795	enddo
	4796	#endif
	4797
	4798	! cam verif
	4799	#ifdef ISOVERIF
	4800	if ((il.eq.1636).and.(i.eq.9)) then
	4801	write(,) 'cv30 4785b: on ajoute le dtr ici:'
	4802	write(,) 'M=',0.1dpinvment(il, k, i)
	4803	write(,) 'q,qe=',rr(il,i),qent(il,k,i)
	4804	endif
	4805	if (iso_eau.gt.0) then
	4806	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
	4807	& fr(il,i),'cv30_routines 3433',errmax,errmaxrel)
	4808	endif !if (iso_eau.gt.0) then
	4809	do ixt=1,niso
	4810	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3436')
	4811	enddo
	4812	if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
	4813	if (iso_verif_aberrant_enc_nostop( &
	4814	& fxt(iso_HDO,il,i)/fr(il,i), &
	4815	& 'cv30_yield 3597').eq.1) then
	4816	write(,) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
	4817	stop
	4818	endif
	4819	endif !if (iso_HDO.gt.0) then
	4820	if ((iso_HDO.gt.0).and. &
	4821	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	4822	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
	4823	& +delt*fxt(iso_HDO,il,i)) &
	4824	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3605b, dtr mels')
	4825	endif !if (iso_HDO.gt.0) then
	4826	#ifdef ISOTRAC
	4827	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3972')
	4828	do ixt=1,ntraciso
	4829	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
	4830	enddo
	4831	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4091',1e-5) &
	4832	& .eq.1) then
	4833	write(,) 'il,i=',il,i
	4834	endif
	4835	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 4091',1e-5)
	4836	#endif
	4837	#endif
	4838	! end cam verif
	4839	#endif
	4840	END IF ! cvflag_grav
	4841	END IF ! i and k
	4842	END DO
	4843	END DO
	4844
	4845	! do j=1,ntra
	4846	! do k=i,nl+1
	4847	! do il=1,ncum
	4848	! if (i.le.inb(il) .and. k.le.inb(il)) then
	4849	! dpinv=1.0/(ph(il,i)-ph(il,i+1))
	4850	! cpinv=1.0/cpn(il,i)
	4851	! if (cvflag_grav) then
	4852	! ftra(il,i,j)=ftra(il,i,j)+0.01gravdpinv*ment(il,k,i)
	4853	! : *(traent(il,k,i,j)-tra(il,i,j))
	4854	! else
	4855	! ftra(il,i,j)=ftra(il,i,j)+0.1dpinvment(il,k,i)
	4856	! : *(traent(il,k,i,j)-tra(il,i,j))
	4857	! endif
	4858	! endif ! i and k
	4859	! enddo
	4860	! enddo
	4861	! enddo
	4862
	4863	DO il = 1, ncum
	4864	IF (i<=inb(il)) THEN
	4865	dpinv = 1.0/(ph(il,i)-ph(il,i+1))
	4866	cpinv = 1.0/cpn(il, i)
	4867
	4868	IF (cvflag_grav) THEN
	4869	! sb: on ne fait pas encore la correction permettant de mieux
	4870	! conserver l'eau:
	4871	fr(il, i) = fr(il, i) + 0.5sigd(evap(il,i)+evap(il,i+1)) + &
	4872	0.01grav(mp(il,i+1)(rp(il,i+1)-rr(il,i))-mp(il,i)(rp(il, &
	4873	i)-rr(il,i-1)))*dpinv
	4874
	4875	fu(il, i) = fu(il, i) + 0.01grav(mp(il,i+1)*(up(il,i+1)-u(il, &
	4876	i))-mp(il,i)(up(il,i)-u(il,i-1)))dpinv
	4877	fv(il, i) = fv(il, i) + 0.01grav(mp(il,i+1)*(vp(il,i+1)-v(il, &
	4878	i))-mp(il,i)(vp(il,i)-v(il,i-1)))dpinv
	4879	#ifdef ISO
	4880	do ixt = 1, niso
	4881	fxt(ixt,il,i)=fxt(ixt,il,i) &
	4882	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
	4883	& +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
	4884	& -mp(il,i) &
	4885	& (xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
	4886	enddo
	4887
	4888	#ifdef DIAGISO
	4889	fq_evapprecip(il,i)=fq_evapprecip(il,i) &
	4890	& +0.5sigd(evap(il,i)+evap(il,i+1))
	4891	fq_ddft(il,i)=fq_ddft(il,i) &
	4892	& +0.01grav(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i) &
	4893	& (rp(il,i)-rr(il,i-1)))dpinv
	4894	do ixt = 1, niso
	4895	fxt_evapprecip(ixt,il,i)=fxt_evapprecip(ixt,il,i) &
	4896	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
	4897	fxt_ddft(ixt,il,i)=fxt_ddft(ixt,il,i) &
	4898	& +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
	4899	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
	4900	enddo
	4901	#endif
	4902
	4903	#ifdef ISOVERIF
	4904	do ixt=1,niso
	4905	call iso_verif_noNaN(xt(ixt,il,i),'cv30_yield 4514')
	4906	call iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 4515')
	4907	enddo
	4908	if ((iso_HDO.gt.0).and. &
	4909	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	4910	if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
	4911	& +delt*fxt(iso_HDO,il,i)) &
	4912	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 4175') &
	4913	& .eq.1) then
	4914	write(,) 'il,i=',il,i
	4915	if (rr(il,i).ne.0.0) then
	4916	write(,) 'il,i,rr,deltaD=',il,i,rr(il,i),deltaD &
	4917	& (xt(iso_HDO,il,i)/rr(il,i))
	4918	endif
	4919	if (fr(il,i).ne.0.0) then
	4920	write(,) 'fr,fxt,deltaD=',fr(il,i),fxt(iso_HDO,il,i), &
	4921	& deltaD(fxt(iso_HDO,il,i)/fr(il,i))
	4922	endif
	4923	#ifdef DIAGISO
	4924	if (fq_ddft(il,i).ne.0.0) then
	4925	write(,) 'fq_ddft,deltaD=',fq_ddft(il,i),deltaD( &
	4926	& fxt_ddft(iso_HDO,il,i)/fq_ddft(il,i))
	4927	endif
	4928	if (fq_evapprecip(il,i).ne.0.0) then
	4929	write(,) 'fq_evapprecip,deltaD=',fq_evapprecip(il,i),deltaD( &
	4930	& fxt_evapprecip(iso_HDO,il,i)/fq_evapprecip(il,i))
	4931	endif
	4932	#endif
	4933	write(,) 'sigd,evap(il,i),evap(il,i+1)=', &
	4934	& sigd,evap(il,i),evap(il,i+1)
	4935	write(,) 'xtevap(iso_HDO,il,i),xtevap(iso_HDO,il,i+1)=', &
	4936	& xtevap(iso_HDO,il,i),xtevap(iso_HDO,il,i+1)
	4937	write(,) 'grav,mp(il,i+1),mp(il,i),dpinv=', &
	4938	& grav,mp(il,i+1),mp(il,i),dpinv
	4939	write(,) 'rp(il,i+1),rr(il,i),rp(il,i),rr(il,i-1)=', &
	4940	& rp(il,i+1),rr(il,i),rp(il,i),rr(il,i-1)
	4941	write(,) 'xtp(il,i+1),xt(il,i),xtp(il,i),xt(il,i-1)=', &
	4942	& xtp(iso_HDO,il,i+1),xt(iso_HDO,il,i), &
	4943	& xtp(iso_HDO,il,i),xt(iso_HDO,il,i-1)
	4944	stop
	4945	endif
	4946	endif !if (iso_HDO.gt.0) then
	4947	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
	4948	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	4949	call iso_verif_O18_aberrant( &
	4950	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
	4951	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
	4952	& 'cv30_yield 5029,O18, evap')
	4953	if ((il.eq.1636).and.(i.eq.9)) then
[4050]	4954	write(,) 'cv30_yield 5057: ici, on verifie deltaD_nobx'
[3927]	4955	write(,) 'il,i=',il,i
	4956	write(,) 'fr(il,i),bx,fr(il,i)-bx=',fr(il,i),bx,fr(il,i)-bx
	4957	write(,) 'q,q+=',rr(il,i),rr(il,i)+delt*(fr(il,i)-bx)
	4958	write(,) 'deltaD,deltaD+=',deltaD(xt(iso_HDO,il,inb(il))/rr(il,inb(il))), &
	4959	& deltaD( (xt(iso_HDO,il,i)+delt(fxt(iso_HDO,il,i)-xtbx(iso_HDO)))/(rr(il,i)+delt(fr(il,i)-bx)))
	4960	write(,) 'deltaO18,deltaO18+=',deltaO(xt(iso_O18,il,inb(il))/rr(il,inb(il))), &
	4961	& deltaO( (xt(iso_O18,il,i)+delt(fxt(iso_O18,il,i)-xtbx(iso_O18)))/(rr(il,i)+delt(fr(il,i)-bx)))
	4962	call iso_verif_O18_aberrant( &
	4963	& (xt(iso_HDO,il,i)+delt*(fxt(iso_HDO,il,i)-xtbx(iso_HDO))) &
	4964	& /(rr(il,i)+delt*(fr(il,i)-bx)), &
	4965	& (xt(iso_O18,il,i)+delt*(fxt(iso_O18,il,i)-xtbx(iso_O18))) &
	4966	& /(rr(il,i)+delt*(fr(il,i)-bx)), &
	4967	& 'cv30_yield 5029_nobx,O18, evap, no bx')
	4968	endif !if ((il.eq.1636).and.(i.eq.9)) then
	4969	endif !if (iso_HDO.gt.0) then
	4970	#endif
	4971
	4972	#ifdef ISOTRAC
	4973	if ((option_traceurs.ne.6).and.(option_traceurs.ne.19)) then
	4974
	4975	! facile: on fait comme l'eau
	4976	do ixt = 1+niso,ntraciso
	4977	fxt(ixt,il,i)=fxt(ixt,il,i) &
	4978	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
	4979	& +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
	4980	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
	4981	enddo !do ixt = 1+niso,ntraciso
	4982
	4983	else ! taggage des ddfts:
	4984	! la formule pour fq_ddft suppose que le ddft est en RP. Ce n'est pas le
[4050]	4985	! cas pour le water tagging puisqu'il y a conversion des molecules
	4986	! blances entrainees en molecule rouges.
[3927]	4987	! Il faut donc prendre en compte ce taux de conversion quand
	4988	! entrainement d'env vers ddft
	4989	! conversion(iiso)=0.01gravdpinv
	4990	! : (mp(il,i)-mp(il,i+1))xt(ixt_poubelle,il,i)
	4991	! fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+conversion(iiso)
	4992	! fxt(ixt_poubelle,il,i)=fxt(ixt_poubelle,il,i)
	4993	! : -conversion(iiso)
	4994
[4050]	4995	! Pb: quand on discretise, dqp/dt n'est pas verifee numeriquement.
	4996	! on se retrouve donc avec des d Ye/dt differents de 0 meme si ye=0 ( on
	4997	! note X les molecules poubelles et Y les molecules ddfts).
[3927]	4998
	4999	! Solution alternative: Dans le cas entrainant, Ye ne varie que par
	5000	! ascendance compensatoire des ddfts et par perte de Ye vers le ddft. On
[4050]	5001	! calcule donc ce terme directement avec schema amont:
[3927]	5002
[4050]	5003	! ajout deja de l'evap
[3927]	5004	do ixt = 1+niso,ntraciso
	5005	fxt(ixt,il,i)=fxt(ixt,il,i) &
	5006	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
	5007	enddo !do ixt = 1+niso,ntraciso
	5008
	5009	! ajout du terme des ddfts sensi stricto
	5010	! write(,) 'tmp cv3_yield 4165: i,il=',i,il
	5011	!
	5012	if (option_traceurs.eq.6) then
	5013	do iiso = 1, niso
	5014
[4143]	5015	ixt_ddft=itZonIso(izone_ddft,iiso)
[3927]	5016	if (mp(il,i).gt.mp(il,i+1)) then
	5017	fxtYe(iiso)=0.01gravdpinv*mp(il,i) &
	5018	& *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
	5019	else !if (mp(il,i).gt.mp(il,i+1)) then
	5020	fxtYe(iiso)=0.01gravdpinv*(mp(il,i) &
	5021	& xt(ixt_ddft,il,i-1)-mp(il,i+1)xt(ixt_ddft,il,i) &
	5022	& +(mp(il,i+1)-mp(il,i))*xtp(ixt_ddft,il,i))
	5023	endif !if (mp(il,i).gt.mp(il,i+1)) then
	5024	fxtqe(iiso)=0.01gravdpinv* &
	5025	& (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
	5026	& -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
	5027
[4143]	5028	ixt_poubelle=itZonIso(izone_poubelle,iiso)
[3927]	5029	fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+fxtYe(iiso)
	5030	fxt(ixt_poubelle,il,i)=fxt(ixt_poubelle,il,i) &
	5031	& +fxtqe(iiso)-fxtYe(iiso)
	5032	enddo !do iiso = 1, niso
	5033
	5034	else !if (option_traceurs.eq.6) then
	5035
	5036
	5037	if (mp(il,i).gt.mp(il,i+1)) then
	5038	! cas entrainant: faire attention
	5039
	5040	do iiso = 1, niso
	5041	fxtqe(iiso)=0.01gravdpinv* &
	5042	& (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
	5043	& -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
	5044
[4143]	5045	ixt_ddft=itZonIso(izone_ddft,iiso)
[3927]	5046	fxtYe(iiso)=0.01gravdpinv*mp(il,i) &
	5047	& *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
	5048	fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+fxtYe(iiso)
	5049
[4143]	5050	ixt_revap=itZonIso(izone_revap,iiso)
[3927]	5051	fxt_revap(iiso)=0.01gravdpinv(mp(il,i+1) &
	5052	& (xtp(ixt_revap,il,i+1)-xt(ixt_revap,il,i)) &
	5053	& -mp(il,i)*(xtp(ixt_revap,il,i)-xt(ixt_revap,il,i-1)))
	5054	fxt(ixt_revap,il,i)=fxt(ixt_revap,il,i) &
	5055	& +fxt_revap(iiso)
	5056
	5057	fxtXe(iiso)=fxtqe(iiso)-fxtYe(iiso)-fxt_revap(iiso)
	5058	Xe(iiso)=xt(iiso,il,i) &
	5059	& -xt(ixt_ddft,il,i)-xt(ixt_revap,il,i)
	5060	if (Xe(iiso).gt.ridicule) then
[4143]	5061	do izone=1,nzone
[3927]	5062	if ((izone.ne.izone_revap).and. &
	5063	& (izone.ne.izone_ddft)) then
[4143]	5064	ixt=itZonIso(izone,iiso)
[3927]	5065	fxt(ixt,il,i)=fxt(ixt,il,i) &
	5066	& +xt(ixt,il,i)/Xe(iiso)*fxtXe(iiso)
	5067	endif !if ((izone.ne.izone_revap).and.
[4143]	5068	enddo !do izone=1,nzone
[3927]	5069	#ifdef ISOVERIF
	5070	! write(,) 'iiso=',iiso
	5071	! write(,) 'fxtqe=',fxtqe(iiso)
	5072	! write(,) 'fxtYe=',fxtYe(iiso)
	5073	! write(,) 'fxt_revap=',fxt_revap(iiso)
	5074	! write(,) 'fxtXe=',fxtXe(iiso)
	5075	! write(,) 'Xe=',Xe(iiso)
	5076	! write(,) 'xt=',xt(:,il,i)
	5077	call iso_verif_traceur_justmass(fxt(1,il,i), &
	5078	& 'cv30_routine 4646')
	5079	#endif
	5080	else !if (abs(dXe).gt.ridicule) then
[4050]	5081	! dans ce cas, fxtXe doit etre faible
[3927]	5082
	5083	#ifdef ISOVERIF
	5084	if (delt*fxtXe(iiso).gt.ridicule) then
	5085	write(,) 'cv30_routines 6563: delt*fxtXe(iiso)=', &
	5086	& delt*fxtXe(iiso)
	5087	stop
	5088	endif
	5089	#endif
[4143]	5090	do izone=1,nzone
[3927]	5091	if ((izone.ne.izone_revap).and. &
	5092	& (izone.ne.izone_ddft)) then
[4143]	5093	ixt=itZonIso(izone,iiso)
[3927]	5094	if (izone.eq.izone_poubelle) then
	5095	fxt(ixt,il,i)=fxt(ixt,il,i)+fxtXe(iiso)
	5096	else !if (izone.eq.izone_poubelle) then
[4050]	5097	! pas de tendance pour ce tag la
[3927]	5098	endif !if (izone.eq.izone_poubelle) then
	5099	endif !if ((izone.ne.izone_revap).and.
[4143]	5100	enddo !do izone=1,nzone
[3927]	5101	#ifdef ISOVERIF
	5102	call iso_verif_traceur_justmass(fxt(1,il,i), &
	5103	& 'cv30_routine 4671')
	5104	#endif
	5105
	5106	endif !if (abs(dXe).gt.ridicule) then
	5107
	5108	enddo !do iiso = 1, niso
	5109
	5110	else !if (mp(il,i).gt.mp(il,i+1)) then
[4050]	5111	! cas detrainant: pas de problemes
[3927]	5112	do ixt=1+niso,ntraciso
	5113	fxt(ixt,il,i)=fxt(ixt,il,i) &
	5114	& +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
	5115	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
	5116	enddo !do ixt=1+niso,ntraciso
	5117	#ifdef ISOVERIF
	5118	call iso_verif_traceur_justmass(fxt(1,il,i), &
	5119	& 'cv30_routine 4685')
	5120	#endif
	5121	endif !if (mp(il,i).gt.mp(il,i+1)) then
	5122
	5123	endif !if (option_traceurs.eq.6) then
	5124
	5125	! write(,) 'deltconversion=',deltconversion(iso_eau)
	5126	! write(,) 'deltfxtYe=',deltfxtYe(iso_eau)
	5127	! write(,) 'deltfxtqe=',deltfxtqe(iso_eau)
	5128
	5129	endif ! if ((option_traceurs.ne.6).and.(option_traceurs.ne.19)) then
	5130	#endif
	5131
	5132	! cam verif
	5133	#ifdef ISOVERIF
	5134	do ixt=1,niso
	5135	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3496')
	5136	enddo
	5137	#endif
	5138	#ifdef ISOVERIF
	5139	if (iso_eau.gt.0) then
	5140	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
	5141	& fr(il,i),'cv30_routines 3493',errmax,errmaxrel)
	5142	endif !if (iso_eau.gt.0) then
	5143	if (1.eq.0) then
	5144	if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
	5145	if (iso_verif_aberrant_enc_nostop( &
	5146	& fxt(iso_HDO,il,i)/fr(il,i), &
	5147	& 'cv30_yield 3662').eq.1) then
	5148	write(,) 'il,i,icb(il),inb(il)=',il,i,icb(il),inb(il)
	5149	write(,) 'fr(il,i),delt=',fr(il,i),delt
	5150	#ifdef DIAGISO
	5151	if (fq_ddft(il,i).ne.0.0) then
	5152	write(,) 'fq_ddft,deltaD=',fq_ddft(il,i),deltaD( &
	5153	& fxt_ddft(iso_HDO,il,i)/fq_ddft(il,i))
	5154	endif !if (fq_ddft(il,i).ne.0.0) then
	5155	if (fq_evapprecip(il,i).ne.0.0) then
	5156	write(,) 'fq_evapprecip,deltaD=',fq_evapprecip(il,i), &
	5157	& deltaD(fxt_evapprecip(iso_HDO,il,i) &
	5158	& /fq_evapprecip(il,i))
	5159	endif !if (fq_evapprecip(il,i).ne.0.0) then
	5160	#endif
	5161	endif !if (iso_verif_aberrant_enc_nostop(
	5162	endif !if (iso_HDO.gt.0) then
	5163	endif !if (1.eq.0) then
	5164	if ((iso_HDO.gt.0).and. &
	5165	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	5166	if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
	5167	& +delt*fxt(iso_HDO,il,i)) &
	5168	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3757, ddfts') &
	5169	& .eq.1) then
	5170	write(,) 'i,il,q,deltaD=',i,il,rr(il,i),deltaD( &
	5171	& xt(iso_HDO,il,i)/rr(il,i))
	5172	write(,) 'i,il,fr,deltaD=',i,il,fr(il,i),deltaD( &
	5173	& fxt(iso_HDO,il,i)/fr(il,i))
	5174	stop
	5175	endif ! if (iso_verif_aberrant_enc_nostop
	5176	endif !if (iso_HDO.gt.0) then
	5177
	5178	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
	5179	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	5180	call iso_verif_O18_aberrant( &
	5181	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
	5182	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
	5183	& 'cv30_yield 5250,O18, ddfts')
	5184	endif !if (iso_HDO.gt.0) then
	5185
	5186	#ifdef ISOTRAC
	5187	! write(,) 'tmp cv3_yield 4224: i,il=',i,il
	5188	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 4107')
	5189	do ixt=1,ntraciso
	5190	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
	5191	enddo
	5192	if (iso_verif_tracpos_choix_nostop(xtnew, &
	5193	& 'cv30_yield 4221',1e-5).eq.1) then
	5194	write(,) 'deltfxt(,il,i)=',deltfxt(1:ntraciso:2,il,i)
	5195	write(,) 'deltfxt(,il,i)=',deltfxt(:,il,i)
	5196	write(,) 'xt(,il,i)=',xt(:,il,i)
	5197	write(,) 'delt,sigd,grav,dpinv=',delt,sigd,grav,dpinv
	5198	write(,) 'xtevap(,il,i)=',xtevap(:,il,i)
	5199	write(,) 'xtevap(,il,i+1)=',xtevap(:,il,i+1)
	5200	write(,) 'mp(il,i+1),mp(il,i)=',mp(il,i+1),mp(il,i)
	5201	write(,) 'xtp(,il,i)=',xtp(:,il,i)
	5202	write(,) 'xtp(,il,i+1)=',xtp(:,il,i+1)
	5203	write(,) 'xt(,il,i)=',xt(:,il,i)
	5204	write(,) 'xt(,il,i-1)=',xt(:,il,i-1)
	5205	! rappel: fxt(ixt,il,i)=fxt(ixt,il,i)
	5206	! 0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
	5207	! : +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i))
	5208	! : -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
	5209	! stop
	5210	endif
	5211	#endif
	5212	#endif
	5213	#endif
	5214	ELSE ! cvflag_grav
	5215	fr(il, i) = fr(il, i) + 0.5sigd(evap(il,i)+evap(il,i+1)) + &
	5216	0.1(mp(il,i+1)(rp(il,i+1)-rr(il,i))-mp(il,i)*(rp(il,i)-rr(il, &
	5217	i-1)))*dpinv
	5218	fu(il, i) = fu(il, i) + 0.1(mp(il,i+1)(up(il,i+1)-u(il, &
	5219	i))-mp(il,i)(up(il,i)-u(il,i-1)))dpinv
	5220	fv(il, i) = fv(il, i) + 0.1(mp(il,i+1)(vp(il,i+1)-v(il, &
	5221	i))-mp(il,i)(vp(il,i)-v(il,i-1)))dpinv
	5222	#ifdef ISO
	5223	do ixt = 1, ntraciso
	5224	fxt(ixt,il,i)=fxt(ixt,il,i) &
	5225	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
	5226	& +0.1(mp(il,i+1)(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
	5227	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
	5228	enddo ! ixt=1,niso
	5229
	5230	#ifdef ISOTRAC
	5231	if (option_traceurs.ne.6) then
	5232
	5233	! facile: on fait comme l'eau
	5234	do ixt = 1+niso,ntraciso
	5235	fxt(ixt,il,i)=fxt(ixt,il,i) &
	5236	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
	5237	& +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
	5238	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
	5239	enddo !do ixt = 1+niso,ntraciso
	5240
	5241	else !if (option_traceurs.ne.6) then
	5242
	5243	! taggage des ddfts: voir blabla + haut
	5244	do ixt = 1+niso,ntraciso
	5245	fxt(ixt,il,i)=fxt(ixt,il,i) &
	5246	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
	5247	enddo !do ixt = 1+niso,ntraciso
	5248	! write(,) 'tmp cv3_yield 4165: i,il=',i,il
[4143]	5249	! ixt_poubelle=itZonIso(izone_poubelle,iso_eau)
	5250	! ixt_ddft=itZonIso(izone_ddft,iso_eau)
[3927]	5251	! write(,) 'delt*fxt(ixt_poubelle,il,i)=',
	5252	! : delt*fxt(ixt_poubelle,il,i)
	5253	! write(,) 'deltfxt(ixt_ddft,il,i)=',deltfxt(ixt_ddft,il,i)
	5254	! write(,) 'xt(iso_eau,il,i)=',xt(iso_eau,il,i)
	5255	do iiso = 1, niso
[4143]	5256	ixt_poubelle=itZonIso(izone_poubelle,iiso)
	5257	ixt_ddft=itZonIso(izone_ddft,iiso)
[3927]	5258	if (mp(il,i).gt.mp(il,i+1)) then
	5259	fxtYe(iiso)=0.01gravdpinv*mp(il,i) &
	5260	& *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
	5261	else !if (mp(il,i).gt.mp(il,i+1)) then
	5262	fxtYe(iiso)=0.01gravdpinv*(mp(il,i) &
	5263	& xt(ixt_ddft,il,i-1)-mp(il,i+1)xt(ixt_ddft,il,i) &
	5264	& +(mp(il,i+1)-mp(il,i))*xtp(ixt_ddft,il,i))
	5265	endif !if (mp(il,i).gt.mp(il,i+1)) then
	5266	fxtqe(iiso)=0.01gravdpinv* &
	5267	& (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
	5268	& -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
	5269	fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+fxtYe(iiso)
	5270	fxt(ixt_poubelle,il,i)=fxt(ixt_poubelle,il,i) &
	5271	& +fxtqe(iiso)-fxtYe(iiso)
	5272	enddo !do iiso = 1, niso
	5273	! write(,) 'deltconversion=',deltconversion(iso_eau)
	5274	! write(,) 'deltfxtYe=',deltfxtYe(iso_eau)
	5275	! write(,) 'deltfxtqe=',deltfxtqe(iso_eau)
	5276	endif !if (option_traceurs.eq.6) then
	5277	#endif
	5278
	5279	#ifdef DIAGISO
	5280	fq_evapprecip(il,i)=fq_evapprecip(il,i) &
	5281	& +0.5sigd(evap(il,i)+evap(il,i+1))
	5282	fq_ddft(il,i)=fq_ddft(il,i) &
	5283	& +0.1(mp(il,i+1)(rp(il,i+1)-rr(il,i))-mp(il,i) &
	5284	& (rp(il,i)-rr(il,i-1)))dpinv
	5285	do ixt = 1, niso
	5286	fxt_evapprecip(ixt,il,i)=fxt_evapprecip(ixt,il,i) &
	5287	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
	5288	fxt_ddft(ixt,il,i)=fxt_ddft(ixt,il,i) &
	5289	& +0.1(mp(il,i+1)(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
	5290	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
	5291	enddo ! ixt=1,niso
	5292	#endif
	5293
	5294	! cam verif
	5295
	5296	#ifdef ISOVERIF
	5297	do ixt=1,niso
	5298	call iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 5083')
	5299	enddo
	5300	#endif
	5301	#ifdef ISOVERIF
	5302	if (iso_eau.gt.0) then
	5303	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
	5304	& fr(il,i),'cv30_routines 3522',errmax,errmaxrel)
	5305	endif !if (iso_eau.gt.0) then
	5306	if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
	5307	if (iso_verif_aberrant_enc_nostop( &
	5308	& fxt(iso_HDO,il,i)/fr(il,i), &
	5309	& 'cv30_yield 3690').eq.1) then
	5310	write(,) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
	5311	stop
	5312	endif
	5313	endif !if (iso_HDO.gt.0) then
	5314	if ((iso_HDO.gt.0).and. &
	5315	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	5316	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
	5317	& +delt*fxt(iso_HDO,il,i)) &
	5318	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3757b, ddfts')
	5319	endif !if (iso_HDO.gt.0) then
	5320	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
	5321	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	5322	call iso_verif_O18_aberrant( &
	5323	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
	5324	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
	5325	& 'cv30_yield 3757b,O18, ddfts')
	5326	endif !if (iso_HDO.gt.0) then
	5327	#ifdef ISOTRAC
	5328	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 4172')
	5329	do ixt=1,ntraciso
	5330	xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
	5331	enddo
	5332	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4295',1e-5) &
	5333	& .eq.1) then
	5334	write(,) 'il,i=',il,i
	5335	endif
	5336	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 4295',1e-5)
	5337	#endif
	5338	#endif
	5339	! end cam verif
	5340	#endif
	5341
	5342	END IF ! cvflag_grav
	5343
	5344	END IF ! i
	5345	END DO
	5346
	5347	! sb: interface with the cloud parameterization: ! cld
	5348
	5349	DO k = i + 1, nl
	5350	DO il = 1, ncum
	5351	IF (k<=inb(il) .AND. i<=inb(il)) THEN ! cld
	5352	! (saturated downdrafts resulting from mixing) ! cld
	5353	qcond(il, i) = qcond(il, i) + elij(il, k, i) ! cld
	5354	nqcond(il, i) = nqcond(il, i) + 1. ! cld
	5355	END IF ! cld
	5356	END DO ! cld
	5357	END DO ! cld
	5358
	5359	! (particular case: no detraining level is found) ! cld
	5360	DO il = 1, ncum ! cld
	5361	IF (i<=inb(il) .AND. nent(il,i)==0) THEN ! cld
	5362	qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i) ! cld
	5363	nqcond(il, i) = nqcond(il, i) + 1. ! cld
	5364	END IF ! cld
	5365	END DO ! cld
	5366
	5367	DO il = 1, ncum ! cld
	5368	IF (i<=inb(il) .AND. nqcond(il,i)/=0.) THEN ! cld
	5369	qcond(il, i) = qcond(il, i)/nqcond(il, i) ! cld
	5370	END IF ! cld
	5371	END DO
	5372
	5373	! do j=1,ntra
	5374	! do il=1,ncum
	5375	! if (i.le.inb(il)) then
	5376	! dpinv=1.0/(ph(il,i)-ph(il,i+1))
	5377	! cpinv=1.0/cpn(il,i)
	5378
	5379	! if (cvflag_grav) then
	5380	! ftra(il,i,j)=ftra(il,i,j)+0.01gravdpinv
	5381	! : (mp(il,i+1)(trap(il,i+1,j)-tra(il,i,j))
	5382	! : -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
	5383	! else
	5384	! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
	5385	! : (mp(il,i+1)(trap(il,i+1,j)-tra(il,i,j))
	5386	! : -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
	5387	! endif
	5388	! endif ! i
	5389	! enddo
	5390	! enddo
	5391
	5392	500 END DO
	5393
	5394
	5395	! * move the detrainment at level inb down to level inb-1 *
	5396	! * in such a way as to preserve the vertically *
	5397	! * integrated enthalpy and water tendencies *
	5398
	5399	DO il = 1, ncum
	5400
[4050]	5401	! attention, on corrige un probleme C Risi
[3927]	5402	IF (cvflag_grav) then
	5403
	5404	ax = 0.01gravment(il, inb(il), inb(il))*(hp(il,inb(il))-h(il,inb(il))+t(il, &
	5405	inb(il))(cpv-cpd)(rr(il,inb(il))-qent(il,inb(il), &
	5406	inb(il))))/(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
	5407	ft(il, inb(il)) = ft(il, inb(il)) - ax
	5408	ft(il, inb(il)-1) = ft(il, inb(il)-1) + axcpn(il, inb(il))(ph(il,inb(il &
	5409	))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il, &
	5410	inb(il))))
	5411
	5412	bx = 0.01gravment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))-rr(il,inb( &
	5413	il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
	5414	fr(il, inb(il)) = fr(il, inb(il)) - bx
	5415	fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+ &
	5416	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
	5417
	5418	cx = 0.01gravment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u(il,inb(il &
	5419	)))/(ph(il,inb(il))-ph(il,inb(il)+1))
	5420	fu(il, inb(il)) = fu(il, inb(il)) - cx
	5421	fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+ &
	5422	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
	5423
	5424	dx = 0.01gravment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v(il,inb(il &
	5425	)))/(ph(il,inb(il))-ph(il,inb(il)+1))
	5426	fv(il, inb(il)) = fv(il, inb(il)) - dx
	5427	fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+ &
	5428	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
	5429
	5430
	5431	#ifdef ISO
	5432	do ixt = 1, ntraciso
	5433	xtbx(ixt)=0.01gravment(il,inb(il),inb(il)) &
	5434	& *(xtent(ixt,il,inb(il),inb(il)) &
	5435	& -xt(ixt,il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
	5436	fxt(ixt,il,inb(il))=fxt(ixt,il,inb(il))-xtbx(ixt)
	5437	fxt(ixt,il,inb(il)-1)=fxt(ixt,il,inb(il)-1) &
	5438	& +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
	5439	& /(ph(il,inb(il)-1)-ph(il,inb(il)))
	5440	enddo !do ixt = 1, niso
	5441	#endif
	5442
	5443	else !IF (cvflag_grav)
	5444	ax = 0.1ment(il, inb(il), inb(il))(hp(il,inb(il))-h(il,inb(il))+t(il, &
	5445	inb(il))(cpv-cpd)(rr(il,inb(il))-qent(il,inb(il), &
	5446	inb(il))))/(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
	5447	ft(il, inb(il)) = ft(il, inb(il)) - ax
	5448	ft(il, inb(il)-1) = ft(il, inb(il)-1) + axcpn(il, inb(il))(ph(il,inb(il &
	5449	))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il, &
	5450	inb(il))))
	5451
	5452	bx = 0.1ment(il, inb(il), inb(il))(qent(il,inb(il),inb(il))-rr(il,inb( &
	5453	il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
	5454	fr(il, inb(il)) = fr(il, inb(il)) - bx
	5455	fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+ &
	5456	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
	5457
	5458	cx = 0.1ment(il, inb(il), inb(il))(uent(il,inb(il),inb(il))-u(il,inb(il &
	5459	)))/(ph(il,inb(il))-ph(il,inb(il)+1))
	5460	fu(il, inb(il)) = fu(il, inb(il)) - cx
	5461	fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+ &
	5462	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
	5463
	5464	dx = 0.1ment(il, inb(il), inb(il))(vent(il,inb(il),inb(il))-v(il,inb(il &
	5465	)))/(ph(il,inb(il))-ph(il,inb(il)+1))
	5466	fv(il, inb(il)) = fv(il, inb(il)) - dx
	5467	fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+ &
	5468	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
	5469
	5470
	5471
	5472	#ifdef ISO
	5473	do ixt = 1, ntraciso
	5474	xtbx(ixt)=0.1*ment(il,inb(il),inb(il)) &
	5475	& *(xtent(ixt,il,inb(il),inb(il)) &
	5476	& -xt(ixt,il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
	5477	fxt(ixt,il,inb(il))=fxt(ixt,il,inb(il))-xtbx(ixt)
	5478	fxt(ixt,il,inb(il)-1)=fxt(ixt,il,inb(il)-1) &
	5479	& +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
	5480	& /(ph(il,inb(il)-1)-ph(il,inb(il)))
	5481	enddo !do ixt = 1, niso
	5482	#endif
	5483
	5484	endif !IF (cvflag_grav)
	5485
	5486
	5487	#ifdef ISO
	5488	#ifdef DIAGISO
	5489	fq_detrainement(il,inb(il))=fq_detrainement(il,inb(il))-bx
	5490	fq_detrainement(il,inb(il)-1)=fq_detrainement(il,inb(il)-1) &
	5491	& +bx*(ph(il,inb(il))-ph(il,inb(il)+1)) &
	5492	& /(ph(il,inb(il)-1)-ph(il,inb(il)))
	5493	do ixt = 1, niso
	5494	fxt_detrainement(ixt,il,inb(il))= &
	5495	& fxt_detrainement(ixt,il,inb(il))-xtbx(ixt)
	5496	fxt_detrainement(ixt,il,inb(il)-1)= &
	5497	& fxt_detrainement(ixt,il,inb(il)-1) &
	5498	& +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
	5499	& /(ph(il,inb(il)-1)-ph(il,inb(il)))
	5500	enddo
	5501	#endif
	5502	! cam verif
	5503	#ifdef ISOVERIF
	5504	do ixt=1,niso
	5505	call iso_verif_noNaN(fxt(ixt,il,inb(il)),'cv30_yield 5083')
	5506	enddo
	5507	if (iso_eau.gt.0) then
	5508	call iso_verif_egalite_choix(fxt(iso_eau,il,inb(il)), &
	5509	& fr(il,inb(il)),'cv30_routines 3638',errmax,errmaxrel)
	5510	call iso_verif_egalite_choix(fxt(iso_eau,il,inb(il)-1), &
	5511	& fr(il,inb(il)-1),'cv30_routines 3640',errmax,errmaxrel)
	5512	endif !if (iso_eau.gt.0) then
	5513	if ((iso_HDO.gt.0).and. &
	5514	& (rr(il,inb(il))+delt*fr(il,inb(il)).gt.ridicule)) then
	5515	call iso_verif_aberrant_encadre( &
	5516	& (xt(iso_HDO,il,inb(il))+delt*fxt(iso_HDO,il,inb(il))) &
	5517	& /(rr(il,inb(il))+delt*fr(il,inb(il))), &
	5518	& 'cv30_yield 3921, en inb')
	5519	if (iso_O18.gt.0) then
	5520	if (iso_verif_O18_aberrant_nostop( &
	5521	& (xt(iso_HDO,il,inb(il))+delt*fxt(iso_HDO,il,inb(il))) &
	5522	& /(rr(il,inb(il))+delt*fr(il,inb(il))), &
	5523	& (xt(iso_O18,il,inb(il))+delt*fxt(iso_O18,il,inb(il))) &
	5524	& /(rr(il,inb(il))+delt*fr(il,inb(il))), &
	5525	& 'cv30_yield 3921O18, en inb').eq.1) then
	5526	write(,) 'il,inb(il)=',il,inb(il)
	5527	k_tmp=0.1*ment(il,inb(il),inb(il))/(ph(il,inb(il))-ph(il,inb(il)+1))
	5528	write(,) 'fr,frprec=',fr(il,inb(il)),fr(il,inb(il))+bx
	5529	write(,) 'M,dt,k_tmpdt=',k_tmp,delt,k_tmpdelt
	5530	write(,) 'q,qe=',rr(il,inb(il)),qent(il,inb(il),inb(il))
	5531	write(,) 'r=',k_tmpdeltqent(il,inb(il),inb(il))/rr(il,inb(il))
	5532	write(,) 'deltaDR,Re=',deltaD(xt(iso_HDO,il,inb(il))/rr(il,inb(il))), &
	5533	& deltaD(xtent(iso_HDO,il,inb(il),inb(il))/qent(il,inb(il),inb(il)))
	5534	write(,) 'deltaO18R,Re=',deltaO(xt(iso_O18,il,inb(il))/rr(il,inb(il))), &
	5535	& deltaO(xtent(iso_O18,il,inb(il),inb(il))/qent(il,inb(il),inb(il)))
	5536	stop
	5537	endif !if (iso_verif_O18_aberrant_nostop
	5538	endif !if (iso_O18.gt.0) then
	5539	endif !if (iso_HDO.gt.0) then
	5540	if ((iso_HDO.gt.0).and. &
	5541	& (rr(il,inb(il)-1)+delt*fr(il,inb(il)-1).gt.ridicule)) then
	5542	call iso_verif_aberrant_encadre( &
	5543	& (xt(iso_HDO,il,inb(il)-1) &
	5544	& +delt*fxt(iso_HDO,il,inb(il)-1)) &
	5545	& /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
	5546	& 'cv30_yield 3921b, en inb-1')
	5547	if (iso_O18.gt.0) then
	5548	call iso_verif_O18_aberrant( &
	5549	& (xt(iso_HDO,il,inb(il)-1)+delt*fxt(iso_HDO,il,inb(il)-1)) &
	5550	& /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
	5551	& (xt(iso_O18,il,inb(il)-1)+delt*fxt(iso_O18,il,inb(il)-1)) &
	5552	& /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
	5553	& 'cv30_yield 3921cO18, en inb-1')
	5554	endif
	5555	endif !if (iso_HDO.gt.0) then
	5556	#ifdef ISOTRAC
	5557	call iso_verif_traceur_justmass(fxt(1,il,inb(il)-1), &
	5558	& 'cv30_routine 4364')
	5559	call iso_verif_traceur_justmass(fxt(1,il,inb(il)), &
	5560	& 'cv30_routine 4364b')
	5561	do ixt=1,ntraciso
	5562	xtnew(ixt)=xt(ixt,il,inb(il))+delt*fxt(ixt,il,inb(il))
	5563	enddo
	5564	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4492',1e-5) &
	5565	& .eq.1) then
	5566	write(,) 'il,i=',il,i
	5567	endif
	5568	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 4492',1e-5)
	5569	#endif
	5570	#endif
	5571	! end cam verif
	5572	#endif
	5573
	5574	END DO
	5575
	5576	! do j=1,ntra
	5577	! do il=1,ncum
	5578	! ex=0.1*ment(il,inb(il),inb(il))
	5579	! : *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
	5580	! : /(ph(il,inb(il))-ph(il,inb(il)+1))
	5581	! ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
	5582	! ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
	5583	! : +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
	5584	! : /(ph(il,inb(il)-1)-ph(il,inb(il)))
	5585	! enddo
	5586	! enddo
	5587
	5588
	5589	! * homoginize tendencies below cloud base *
	5590
	5591
	5592	DO il = 1, ncum
	5593	asum(il) = 0.0
	5594	bsum(il) = 0.0
	5595	csum(il) = 0.0
	5596	dsum(il) = 0.0
	5597	#ifdef ISO
	5598	frsum(il)=0.0
	5599	do ixt=1,ntraciso
	5600	fxtsum(ixt,il)=0.0
	5601	bxtsum(ixt,il)=0.0
	5602	enddo
	5603	#endif
	5604	END DO
	5605
	5606	DO i = 1, nl
	5607	DO il = 1, ncum
	5608	IF (i<=(icb(il)-1)) THEN
	5609	asum(il) = asum(il) + ft(il, i)*(ph(il,i)-ph(il,i+1))
	5610	bsum(il) = bsum(il) + fr(il, i)(lv(il,i)+(cl-cpd)(t(il,i)-t(il, &
	5611	1)))*(ph(il,i)-ph(il,i+1))
	5612	csum(il) = csum(il) + (lv(il,i)+(cl-cpd)*(t(il,i)-t(il, &
	5613	1)))*(ph(il,i)-ph(il,i+1))
	5614	dsum(il) = dsum(il) + t(il, i)*(ph(il,i)-ph(il,i+1))/th(il, i)
	5615	#ifdef ISO
	5616
	5617	frsum(il)=frsum(il)+fr(il,i)
	5618	do ixt=1,ntraciso
	5619	fxtsum(ixt,il)=fxtsum(ixt,il)+fxt(ixt,il,i)
	5620	bxtsum(ixt,il)=bxtsum(ixt,il)+fxt(ixt,il,i) &
	5621	& (lv(il,i)+(cl-cpd)(t(il,i)-t(il,1))) &
	5622	& *(ph(il,i)-ph(il,i+1))
	5623	enddo
	5624	#endif
	5625	END IF
	5626	END DO
	5627	END DO
	5628
	5629	! !!! do 700 i=1,icb(il)-1
	5630	DO i = 1, nl
	5631	DO il = 1, ncum
	5632	IF (i<=(icb(il)-1)) THEN
	5633	ft(il, i) = asum(il)t(il, i)/(th(il,i)dsum(il))
	5634	fr(il, i) = bsum(il)/csum(il)
	5635	#ifdef ISO
	5636	if (abs(csum(il)).gt.0.0) then
	5637	do ixt=1,ntraciso
	5638	fxt(ixt,il,i)=bxtsum(ixt,il)/csum(il)
	5639	enddo
	5640	else !if (frsum(il).gt.ridicule) then
	5641	if (abs(frsum(il)).gt.0.0) then
	5642	do ixt=1,ntraciso
	5643	fxt(ixt,il,i)=fr(il,i)*fxtsum(ixt,il)/frsum(il)
	5644	enddo
	5645	else !if (abs(frsum(il)).gt.0.0) then
	5646	if (abs(fr(il,i))*delt.gt.ridicule) then
	5647	write(,) 'cv30_yield 4048: fr(il,i)=',fr(il,i)
	5648	stop
	5649	else !if (abs(fr(il,i))*delt.gt.ridicule) then
	5650	do ixt=1,ntraciso
	5651	fxt(ixt,il,i)=0.0
	5652	enddo
	5653	if (iso_eau.gt.0) then
	5654	fxt(iso_eau,il,i)=1.0
	5655	endif
	5656	endif !if (abs(fr(il,i))*delt.gt.ridicule) then
	5657	endif !if (abs(frsum(il)).gt.0.0) then
	5658	endif !if (frsum(il).gt.0) then
	5659	#endif
	5660	END IF
	5661	END DO
	5662	END DO
	5663
	5664
	5665	#ifdef ISO
	5666	#ifdef ISOVERIF
	5667	do i=1,nl
	5668	do il=1,ncum
	5669	do ixt=1,ntraciso
	5670	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_yield 3826')
	5671	enddo
	5672	enddo
	5673	enddo
	5674	#endif
	5675	#ifdef ISOVERIF
	5676	do i=1,nl
	5677	! write(,) 'cv30_routines temp 3967: i=',i
	5678	do il=1,ncum
	5679	! write(,) 'cv30_routines 3969: il=',il
	5680	! write(,) 'cv30_routines temp 3967: il,i,inb(il),ncum=',
	5681	! : il,i,inb(il),ncum
	5682	! write(,) 'cv30_routines 3974'
	5683	if (iso_eau.gt.0) then
	5684	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
	5685	& fr(il,i),'cv30_yield 3830',errmax,errmaxrel)
	5686	endif !if (iso_eau.gt.0) then
	5687	! write(,) 'cv30_routines 3979'
	5688	if ((iso_HDO.gt.0).and. &
	5689	& (delt*fr(il,i).gt.ridicule)) then
	5690	if (iso_verif_aberrant_enc_nostop( &
	5691	& fxt(iso_HDO,il,i)/fr(il,i), &
	5692	& 'cv30_yield 3834').eq.1) then
	5693	if (fr(il,i).gt.ridicule*1e5) then
	5694	write(,) 'il,i,icb(il)=',il,i,icb(il)
	5695	write(,) 'frsum(il)=',frsum(il)
	5696	write(,) 'fr(il,i)=',fr(il,i)
	5697	write(,) 'csum(il)=',csum(il)
	5698	write(,) &
	5699	& 'deltaD(bxtsum(iso_HDO,il)/csum(il))=', &
	5700	& deltaD(bxtsum(iso_HDO,il)/csum(il))
	5701	! stop
	5702	endif
	5703	! write(,) 'cv30_routines 3986: temporaire'
	5704	endif !if (iso_verif_aberrant_enc_nostop
	5705	endif !if (iso_HDO.gt.0) then
	5706	if ((iso_HDO.gt.0).and. &
	5707	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	5708	if (iso_verif_aberrant_enc_nostop( &
	5709	& (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
	5710	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3921c, dans la CL') &
	5711	& .eq.1) then
	5712	write(,) 'il,i,icb(il)=',il,i,icb(il)
	5713	write(,) 'frsum(il)=',frsum(il)
	5714	write(,) 'fr(il,i)=',fr(il,i)
	5715	stop
	5716	endif
	5717	endif !if (iso_HDO.gt.0) then
	5718
	5719	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
	5720	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	5721	call iso_verif_O18_aberrant( &
	5722	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
	5723	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
	5724	& 'cv30_yield 3921d, dans la CL')
	5725	endif !if (iso_HDO.gt.0) then
	5726	#ifdef ISOTRAC
	5727	call iso_verif_traceur_justmass(fxt(1,il,i), &
	5728	& 'cv30_routine 4523')
	5729	#endif
	5730	! write(,) 'cv30_routines 3994'
	5731	enddo !do il=1,ncum
	5732	! write(,) 'cv30_routine 3990: fin des il pour i=',i
	5733	enddo !do i=1,nl
[4050]	5734	! write(,) 'cv30_routine 3990: fin des verifs sur homogen'
[3927]	5735	#endif
	5736
	5737	#ifdef ISOVERIF
	5738	! verif finale des tendances:
	5739	do i=1,nl
	5740	do il=1,ncum
	5741	if (iso_eau.gt.0) then
	5742	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
	5743	& fr(il,i),'cv30_yield 3830',errmax,errmaxrel)
	5744	endif !if (iso_eau.gt.0) then
	5745	if ((iso_HDO.gt.0).and. &
	5746	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	5747	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
	5748	& +delt*fxt(iso_HDO,il,i)) &
	5749	& /(rr(il,i)+delt*fr(il,i)), &
	5750	& 'cv30_yield 5710a, final')
	5751	endif !if (iso_HDO.gt.0) then
	5752	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
	5753	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
	5754	call iso_verif_O18_aberrant( &
	5755	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
	5756	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
	5757	& 'cv30_yield 5710b, final')
	5758	endif !if (iso_HDO.gt.0) then
	5759	enddo !do il=1,ncum
	5760	enddo !do i=1,nl
	5761	#endif
	5762
	5763	#endif
	5764
	5765
	5766	! * reset counter and return *
	5767
	5768	DO il = 1, ncum
	5769	sig(il, nd) = 2.0
	5770	END DO
	5771
	5772
	5773	DO i = 1, nd
	5774	DO il = 1, ncum
	5775	upwd(il, i) = 0.0
	5776	dnwd(il, i) = 0.0
	5777	END DO
	5778	END DO
	5779
	5780	DO i = 1, nl
	5781	DO il = 1, ncum
	5782	dnwd0(il, i) = -mp(il, i)
	5783	END DO
	5784	END DO
	5785	DO i = nl + 1, nd
	5786	DO il = 1, ncum
	5787	dnwd0(il, i) = 0.
	5788	END DO
	5789	END DO
	5790
	5791
	5792	DO i = 1, nl
	5793	DO il = 1, ncum
	5794	IF (i>=icb(il) .AND. i<=inb(il)) THEN
	5795	upwd(il, i) = 0.0
	5796	dnwd(il, i) = 0.0
	5797	END IF
	5798	END DO
	5799	END DO
	5800
	5801	DO i = 1, nl
	5802	DO k = 1, nl
	5803	DO il = 1, ncum
	5804	up1(il, k, i) = 0.0
	5805	dn1(il, k, i) = 0.0
	5806	END DO
	5807	END DO
	5808	END DO
	5809
	5810	DO i = 1, nl
	5811	DO k = i, nl
	5812	DO n = 1, i - 1
	5813	DO il = 1, ncum
	5814	IF (i>=icb(il) .AND. i<=inb(il) .AND. k<=inb(il)) THEN
	5815	up1(il, k, i) = up1(il, k, i) + ment(il, n, k)
	5816	dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n)
	5817	END IF
	5818	END DO
	5819	END DO
	5820	END DO
	5821	END DO
	5822
	5823	DO i = 2, nl
	5824	DO k = i, nl
	5825	DO il = 1, ncum
	5826	! test if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il))
	5827	! then
	5828	IF (i<=inb(il) .AND. k<=inb(il)) THEN
	5829	upwd(il, i) = upwd(il, i) + m(il, k) + up1(il, k, i)
	5830	dnwd(il, i) = dnwd(il, i) + dn1(il, k, i)
	5831	END IF
	5832	END DO
	5833	END DO
	5834	END DO
	5835
	5836
	5837	! !!! DO il=1,ncum
	5838	! !!! do i=icb(il),inb(il)
	5839	! !!!
	5840	! !!! upwd(il,i)=0.0
	5841	! !!! dnwd(il,i)=0.0
	5842	! !!! do k=i,inb(il)
	5843	! !!! up1=0.0
	5844	! !!! dn1=0.0
	5845	! !!! do n=1,i-1
	5846	! !!! up1=up1+ment(il,n,k)
	5847	! !!! dn1=dn1-ment(il,k,n)
	5848	! !!! enddo
	5849	! !!! upwd(il,i)=upwd(il,i)+m(il,k)+up1
	5850	! !!! dnwd(il,i)=dnwd(il,i)+dn1
	5851	! !!! enddo
	5852	! !!! enddo
	5853	! !!!
	5854	! !!! ENDDO
	5855
	5856	! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	5857	! determination de la variation de flux ascendant entre
	5858	! deux niveau non dilue mike
	5859	! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	5860
	5861	DO i = 1, nl
	5862	DO il = 1, ncum
	5863	mike(il, i) = m(il, i)
	5864	END DO
	5865	END DO
	5866
	5867	DO i = nl + 1, nd
	5868	DO il = 1, ncum
	5869	mike(il, i) = 0.
	5870	END DO
	5871	END DO
	5872
	5873	DO i = 1, nd
	5874	DO il = 1, ncum
	5875	ma(il, i) = 0
	5876	END DO
	5877	END DO
	5878
	5879	DO i = 1, nl
	5880	DO j = i, nl
	5881	DO il = 1, ncum
	5882	ma(il, i) = ma(il, i) + m(il, j)
	5883	END DO
	5884	END DO
	5885	END DO
	5886
	5887	DO i = nl + 1, nd
	5888	DO il = 1, ncum
	5889	ma(il, i) = 0.
	5890	END DO
	5891	END DO
	5892
	5893	DO i = 1, nl
	5894	DO il = 1, ncum
	5895	IF (i<=(icb(il)-1)) THEN
	5896	ma(il, i) = 0
	5897	END IF
	5898	END DO
	5899	END DO
	5900
	5901	! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	5902	! icb represente de niveau ou se trouve la
	5903	! base du nuage , et inb le top du nuage
	5904	! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	5905
	5906	DO i = 1, nd
	5907	DO il = 1, ncum
	5908	mke(il, i) = upwd(il, i) + dnwd(il, i)
	5909	END DO
	5910	END DO
	5911
	5912	DO i = 1, nd
	5913	DO il = 1, ncum
	5914	rdcp = (rrd(1.-rr(il,i))-rr(il,i)rrv)/(cpd*(1.-rr(il, &
	5915	i))+rr(il,i)*cpv)
	5916	tls(il, i) = t(il, i)(1000.0/p(il,i))*rdcp
	5917	tps(il, i) = tp(il, i)
	5918	END DO
	5919	END DO
	5920
	5921
	5922	! * diagnose the in-cloud mixing ratio * ! cld
	5923	! * of condensed water * ! cld
	5924	! ! cld
	5925
	5926	DO i = 1, nd ! cld
	5927	DO il = 1, ncum ! cld
	5928	mac(il, i) = 0.0 ! cld
	5929	wa(il, i) = 0.0 ! cld
	5930	siga(il, i) = 0.0 ! cld
	5931	sax(il, i) = 0.0 ! cld
	5932	END DO ! cld
	5933	END DO ! cld
	5934
	5935	DO i = minorig, nl ! cld
	5936	DO k = i + 1, nl + 1 ! cld
	5937	DO il = 1, ncum ! cld
	5938	IF (i<=inb(il) .AND. k<=(inb(il)+1)) THEN ! cld
	5939	mac(il, i) = mac(il, i) + m(il, k) ! cld
	5940	END IF ! cld
	5941	END DO ! cld
	5942	END DO ! cld
	5943	END DO ! cld
	5944
	5945	DO i = 1, nl ! cld
	5946	DO j = 1, i ! cld
	5947	DO il = 1, ncum ! cld
	5948	IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
	5949	.AND. j>=icb(il)) THEN ! cld
	5950	sax(il, i) = sax(il, i) + rrd*(tvp(il,j)-tv(il,j)) & ! cld
	5951	*(ph(il,j)-ph(il,j+1))/p(il, j) ! cld
	5952	END IF ! cld
	5953	END DO ! cld
	5954	END DO ! cld
	5955	END DO ! cld
	5956
	5957	DO i = 1, nl ! cld
	5958	DO il = 1, ncum ! cld
	5959	IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
	5960	.AND. sax(il,i)>0.0) THEN ! cld
	5961	wa(il, i) = sqrt(2.*sax(il,i)) ! cld
	5962	END IF ! cld
	5963	END DO ! cld
	5964	END DO ! cld
	5965
	5966	DO i = 1, nl ! cld
	5967	DO il = 1, ncum ! cld
	5968	IF (wa(il,i)>0.0) & ! cld
	5969	siga(il, i) = mac(il, i)/wa(il, i) & ! cld
	5970	rrdtvp(il, i)/p(il, i)/100./delta ! cld
	5971	siga(il, i) = min(siga(il,i), 1.0) ! cld
	5972	! IM cf. FH
	5973	IF (iflag_clw==0) THEN
	5974	qcondc(il, i) = siga(il, i)clw(il, i)(1.-ep(il,i)) & ! cld
	5975	+(1.-siga(il,i))*qcond(il, i) ! cld
	5976	ELSE IF (iflag_clw==1) THEN
	5977	qcondc(il, i) = qcond(il, i) ! cld
	5978	END IF
	5979
	5980	END DO ! cld
	5981	END DO ! cld
	5982
	5983	RETURN
	5984	END SUBROUTINE cv30_yield
	5985
	5986	! !RomP >>>
	5987	SUBROUTINE cv30_tracer(nloc, len, ncum, nd, na, ment, sij, da, phi, phi2, &
	5988	d1a, dam, ep, vprecip, elij, clw, epmlmmm, eplamm, icb, inb)
	5989	IMPLICIT NONE
	5990
	5991	include "cv30param.h"
	5992
	5993	! inputs:
	5994	INTEGER ncum, nd, na, nloc, len
	5995	REAL ment(nloc, na, na), sij(nloc, na, na)
	5996	REAL clw(nloc, nd), elij(nloc, na, na)
	5997	REAL ep(nloc, na)
	5998	INTEGER icb(nloc), inb(nloc)
	5999	REAL vprecip(nloc, nd+1)
	6000	! ouputs:
	6001	REAL da(nloc, na), phi(nloc, na, na)
	6002	REAL phi2(nloc, na, na)
	6003	REAL d1a(nloc, na), dam(nloc, na)
	6004	REAL epmlmmm(nloc, na, na), eplamm(nloc, na)
	6005	! variables pour tracer dans precip de l'AA et des mel
	6006	! local variables:
	6007	INTEGER i, j, k, nam1
	6008	REAL epm(nloc, na, na)
	6009
	6010	nam1=na-1 ! Introduced because ep is not defined for j=na
	6011	! variables d'Emanuel : du second indice au troisieme
	6012	! ---> tab(i,k,j) -> de l origine k a l arrivee j
	6013	! ment, sij, elij
	6014	! variables personnelles : du troisieme au second indice
	6015	! ---> tab(i,j,k) -> de k a j
	6016	! phi, phi2
	6017
	6018	! initialisations
	6019	DO j = 1, na
	6020	DO i = 1, ncum
	6021	da(i, j) = 0.
	6022	d1a(i, j) = 0.
	6023	dam(i, j) = 0.
	6024	eplamm(i, j) = 0.
	6025	END DO
	6026	END DO
	6027	DO k = 1, na
	6028	DO j = 1, na
	6029	DO i = 1, ncum
	6030	epm(i, j, k) = 0.
	6031	epmlmmm(i, j, k) = 0.
	6032	phi(i, j, k) = 0.
	6033	phi2(i, j, k) = 0.
	6034	END DO
	6035	END DO
	6036	END DO
	6037
	6038	! fraction deau condensee dans les melanges convertie en precip : epm
[4050]	6039	! et eau condensee precipitee dans masse d'air sature : l_m*dM_m/dzdz.dzdz
[3927]	6040	DO j = 1, nam1
	6041	DO k = 1, j - 1
	6042	DO i = 1, ncum
	6043	IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
	6044	! !jyg epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
	6045	epm(i, j, k) = 1. - (1.-ep(i,j))*clw(i, j)/max(elij(i,k,j), 1.E-16)
	6046	! !
	6047	epm(i, j, k) = max(epm(i,j,k), 0.0)
	6048	END IF
	6049	END DO
	6050	END DO
	6051	END DO
	6052
	6053	DO j = 1, nam1
	6054	DO k = 1, nam1
	6055	DO i = 1, ncum
	6056	IF (k>=icb(i) .AND. k<=inb(i)) THEN
	6057	eplamm(i, j) = eplamm(i, j) + ep(i, j)clw(i, j)ment(i, j, k)*(1.- &
	6058	sij(i,j,k))
	6059	END IF
	6060	END DO
	6061	END DO
	6062	END DO
	6063
	6064	DO j = 1, nam1
	6065	DO k = 1, j - 1
	6066	DO i = 1, ncum
	6067	IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
	6068	epmlmmm(i, j, k) = epm(i, j, k)elij(i, k, j)ment(i, k, j)
	6069	END IF
	6070	END DO
	6071	END DO
	6072	END DO
	6073
	6074	! matrices pour calculer la tendance des concentrations dans cvltr.F90
	6075	DO j = 1, nam1
	6076	DO k = 1, nam1
	6077	DO i = 1, ncum
	6078	da(i, j) = da(i, j) + (1.-sij(i,k,j))*ment(i, k, j)
	6079	phi(i, j, k) = sij(i, k, j)*ment(i, k, j)
	6080	d1a(i, j) = d1a(i, j) + ment(i, k, j)ep(i, k)(1.-sij(i,k,j))
	6081	END DO
	6082	END DO
	6083	END DO
	6084
	6085	DO j = 1, nam1
	6086	DO k = 1, j - 1
	6087	DO i = 1, ncum
	6088	dam(i, j) = dam(i, j) + ment(i, k, j)epm(i, j, k)(1.-ep(i,k))*(1.- &
	6089	sij(i,k,j))
	6090	phi2(i, j, k) = phi(i, j, k)*epm(i, j, k)
	6091	END DO
	6092	END DO
	6093	END DO
	6094
	6095	RETURN
	6096	END SUBROUTINE cv30_tracer
	6097	! RomP <<<
	6098
	6099	SUBROUTINE cv30_uncompress(nloc, len, ncum, nd, ntra, idcum, iflag, precip, &
	6100	vprecip, evap, ep, sig, w0, ft, fq, fu, fv, ftra, inb, ma, upwd, dnwd, &
	6101	dnwd0, qcondc, wd, cape, da, phi, mp, phi2, d1a, dam, sij, elij, clw, &
	6102	epmlmmm, eplamm, wdtraina, wdtrainm,epmax_diag, iflag1, precip1, vprecip1, evap1, &
	6103	ep1, sig1, w01, ft1, fq1, fu1, fv1, ftra1, inb1, ma1, upwd1, dnwd1, &
	6104	dnwd01, qcondc1, wd1, cape1, da1, phi1, mp1, phi21, d1a1, dam1, sij1, &
	6105	elij1, clw1, epmlmmm1, eplamm1, wdtraina1, wdtrainm1,epmax_diag1 & ! epmax_cape
	6106	#ifdef ISO
	6107	& ,xtprecip,fxt,xtVPrecip,xtevap,xtclw,xtwdtraina &
	6108	& ,xtprecip1,fxt1,xtVPrecip1,xtevap1,xtclw1,xtwdtraina1 &
	6109	#ifdef DIAGISO
	6110	& , water,xtwater,qp,xtp &
	6111	& , fq_detrainement,fq_ddft,fq_fluxmasse,fq_evapprecip &
	6112	& , fxt_detrainement,fxt_ddft,fxt_fluxmasse, fxt_evapprecip &
	6113	& , f_detrainement,q_detrainement,xt_detrainement &
	6114	& , water1,xtwater1,qp1,xtp1 &
	6115	& , fq_detrainement1,fq_ddft1,fq_fluxmasse1,fq_evapprecip1 &
	6116	& , fxt_detrainement1,fxt_ddft1,fxt_fluxmasse1, fxt_evapprecip1 &
	6117	& , f_detrainement1,q_detrainement1,xt_detrainement1 &
	6118	#endif
	6119	#endif
	6120	& )
	6121
	6122	#ifdef ISO
[4143]	6123	use infotrac_phy, ONLY: ntraciso=>ntiso
[3927]	6124	#ifdef ISOVERIF
	6125	use isotopes_verif_mod, ONLY: Tmin_verif,iso_verif_aberrant, &
	6126	iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
	6127	iso_verif_egalite_nostop,iso_verif_aberrant_nostop,deltaD,iso_verif_noNaN_nostop, &
	6128	iso_verif_positif,iso_verif_egalite_vect2D
	6129	#endif
	6130	#endif
	6131	IMPLICIT NONE
	6132
	6133	include "cv30param.h"
	6134
	6135	! inputs:
	6136	INTEGER len, ncum, nd, ntra, nloc
	6137	INTEGER idcum(nloc)
	6138	INTEGER iflag(nloc)
	6139	INTEGER inb(nloc)
	6140	REAL precip(nloc)
	6141	REAL vprecip(nloc, nd+1), evap(nloc, nd)
	6142	REAL ep(nloc, nd)
	6143	REAL sig(nloc, nd), w0(nloc, nd)
	6144	REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
	6145	REAL ftra(nloc, nd, ntra)
	6146	REAL ma(nloc, nd)
	6147	REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
	6148	REAL qcondc(nloc, nd)
	6149	REAL wd(nloc), cape(nloc)
	6150	REAL da(nloc, nd), phi(nloc, nd, nd), mp(nloc, nd)
	6151	REAL epmax_diag(nloc) ! epmax_cape
	6152	! RomP >>>
	6153	REAL phi2(nloc, nd, nd)
	6154	REAL d1a(nloc, nd), dam(nloc, nd)
	6155	REAL wdtraina(nloc, nd), wdtrainm(nloc, nd)
	6156	REAL sij(nloc, nd, nd)
	6157	REAL elij(nloc, nd, nd), clw(nloc, nd)
	6158	REAL epmlmmm(nloc, nd, nd), eplamm(nloc, nd)
	6159	! RomP <<<
	6160	#ifdef ISO
	6161	REAL xtprecip(ntraciso,nloc)
	6162	REAL xtvprecip(ntraciso,nloc, nd+1), xtevap(ntraciso,nloc, nd)
	6163	real fxt(ntraciso,nloc,nd)
	6164	real xtclw(ntraciso,nloc,nd)
	6165	REAL xtwdtraina(ntraciso,nloc, nd)
	6166	#endif
	6167
	6168	! outputs:
	6169	INTEGER iflag1(len)
	6170	INTEGER inb1(len)
	6171	REAL precip1(len)
	6172	REAL vprecip1(len, nd+1), evap1(len, nd) !<<< RomP
	6173	REAL ep1(len, nd) !<<< RomP
	6174	REAL sig1(len, nd), w01(len, nd)
	6175	REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
	6176	REAL ftra1(len, nd, ntra)
	6177	REAL ma1(len, nd)
	6178	REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd)
	6179	REAL qcondc1(nloc, nd)
	6180	REAL wd1(nloc), cape1(nloc)
	6181	REAL da1(nloc, nd), phi1(nloc, nd, nd), mp1(nloc, nd)
	6182	REAL epmax_diag1(len) ! epmax_cape
	6183	! RomP >>>
	6184	REAL phi21(len, nd, nd)
	6185	REAL d1a1(len, nd), dam1(len, nd)
	6186	REAL wdtraina1(len, nd), wdtrainm1(len, nd)
	6187	REAL sij1(len, nd, nd)
	6188	REAL elij1(len, nd, nd), clw1(len, nd)
	6189	REAL epmlmmm1(len, nd, nd), eplamm1(len, nd)
	6190	! RomP <<<
	6191	#ifdef ISO
	6192	real xtprecip1(ntraciso,len)
	6193	real fxt1(ntraciso,len,nd)
	6194	real xtVPrecip1(ntraciso,len,nd+1),xtevap1(ntraciso,len, nd)
	6195	REAL xtwdtraina1(ntraciso,len, nd)
	6196	REAL xtclw1(ntraciso,len, nd)
	6197	#endif
	6198
	6199	! local variables:
	6200	INTEGER i, k, j
	6201	#ifdef ISO
	6202	integer ixt
	6203	#endif
	6204
	6205	#ifdef DIAGISO
	6206	real water(nloc,nd)
	6207	real xtwater(ntraciso,nloc,nd)
	6208	real qp(nloc,nd),xtp(ntraciso,nloc,nd)
	6209	real fq_detrainement(nloc,nd)
	6210	real f_detrainement(nloc,nd)
	6211	real q_detrainement(nloc,nd)
	6212	real fq_ddft(nloc,nd)
	6213	real fq_fluxmasse(nloc,nd)
	6214	real fq_evapprecip(nloc,nd)
	6215	real fxt_detrainement(ntraciso,nloc,nd)
	6216	real xt_detrainement(ntraciso,nloc,nd)
	6217	real fxt_ddft(ntraciso,nloc,nd)
	6218	real fxt_fluxmasse(ntraciso,nloc,nd)
	6219	real fxt_evapprecip(ntraciso,nloc,nd)
	6220
	6221	real water1(len,nd)
	6222	real xtwater1(ntraciso,len,nd)
	6223	real qp1(len,nd),xtp1(ntraciso,len,nd)
	6224	real fq_detrainement1(len,nd)
	6225	real f_detrainement1(len,nd)
	6226	real q_detrainement1(len,nd)
	6227	real fq_ddft1(len,nd)
	6228	real fq_fluxmasse1(len,nd)
	6229	real fq_evapprecip1(len,nd)
	6230	real fxt_detrainement1(ntraciso,len,nd)
	6231	real xt_detrainement1(ntraciso,len,nd)
	6232	real fxt_ddft1(ntraciso,len,nd)
	6233	real fxt_fluxmasse1(ntraciso,len,nd)
	6234	real fxt_evapprecip1(ntraciso,len,nd)
	6235	#endif
	6236
	6237	#ifdef ISOVERIF
[4050]	6238	write(,) 'cv30_routines 4293: entree dans cv3_uncompress'
[3927]	6239	#endif
	6240	DO i = 1, ncum
	6241	precip1(idcum(i)) = precip(i)
	6242	iflag1(idcum(i)) = iflag(i)
	6243	wd1(idcum(i)) = wd(i)
	6244	inb1(idcum(i)) = inb(i)
	6245	cape1(idcum(i)) = cape(i)
	6246	epmax_diag1(idcum(i))=epmax_diag(i) ! epmax_cape
	6247	#ifdef ISO
	6248	do ixt = 1, ntraciso
	6249	xtprecip1(ixt,idcum(i))=xtprecip(ixt,i)
	6250	enddo
	6251	#endif
	6252	END DO
	6253
	6254	DO k = 1, nl
	6255	DO i = 1, ncum
	6256	vprecip1(idcum(i), k) = vprecip(i, k)
	6257	evap1(idcum(i), k) = evap(i, k) !<<< RomP
	6258	sig1(idcum(i), k) = sig(i, k)
	6259	w01(idcum(i), k) = w0(i, k)
	6260	ft1(idcum(i), k) = ft(i, k)
	6261	fq1(idcum(i), k) = fq(i, k)
	6262	fu1(idcum(i), k) = fu(i, k)
	6263	fv1(idcum(i), k) = fv(i, k)
	6264	ma1(idcum(i), k) = ma(i, k)
	6265	upwd1(idcum(i), k) = upwd(i, k)
	6266	dnwd1(idcum(i), k) = dnwd(i, k)
	6267	dnwd01(idcum(i), k) = dnwd0(i, k)
	6268	qcondc1(idcum(i), k) = qcondc(i, k)
	6269	da1(idcum(i), k) = da(i, k)
	6270	mp1(idcum(i), k) = mp(i, k)
	6271	! RomP >>>
	6272	ep1(idcum(i), k) = ep(i, k)
	6273	d1a1(idcum(i), k) = d1a(i, k)
	6274	dam1(idcum(i), k) = dam(i, k)
	6275	clw1(idcum(i), k) = clw(i, k)
	6276	eplamm1(idcum(i), k) = eplamm(i, k)
	6277	wdtraina1(idcum(i), k) = wdtraina(i, k)
	6278	wdtrainm1(idcum(i), k) = wdtrainm(i, k)
	6279	! RomP <<<
	6280	#ifdef ISO
	6281	do ixt = 1, ntraciso
	6282	fxt1(ixt,idcum(i),k)=fxt(ixt,i,k)
	6283	xtVPrecip1(ixt,idcum(i),k)=xtVPrecip(ixt,i,k)
	6284	xtevap1(ixt,idcum(i),k)=xtevap(ixt,i,k)
	6285	xtwdtraina1(ixt,idcum(i),k)=xtwdtraina(ixt,i,k)
	6286	xtclw1(ixt,idcum(i),k)=xtclw(ixt,i,k)
	6287	enddo
	6288	#endif
	6289	END DO
	6290	END DO
	6291
	6292	DO i = 1, ncum
	6293	sig1(idcum(i), nd) = sig(i, nd)
	6294	END DO
	6295
	6296
	6297
	6298
	6299	#ifdef ISO
	6300	#ifdef DIAGISO
	6301	do k=1,nl
	6302	do i=1,ncum
	6303	water1(idcum(i),k)=water(i,k)
	6304	qp1(idcum(i),k)=qp(i,k)
	6305	evap1(idcum(i),k)=evap(i,k)
	6306	fq_detrainement1(idcum(i),k)=fq_detrainement(i,k)
	6307	f_detrainement1(idcum(i),k)=f_detrainement(i,k)
	6308	q_detrainement1(idcum(i),k)=q_detrainement(i,k)
	6309	fq_ddft1(idcum(i),k)=fq_ddft(i,k)
	6310	fq_evapprecip1(idcum(i),k)=fq_evapprecip(i,k)
	6311	fq_fluxmasse1(idcum(i),k)=fq_fluxmasse(i,k)
	6312	do ixt = 1, ntraciso
	6313	xtwater1(ixt,idcum(i),k)=xtwater(ixt,i,k)
	6314	xtp1(ixt,idcum(i),k)=xtp(ixt,i,k)
	6315	fxt_detrainement1(ixt,idcum(i),k)=fxt_detrainement(ixt,i,k)
	6316	xt_detrainement1(ixt,idcum(i),k)=xt_detrainement(ixt,i,k)
	6317	fxt_ddft1(ixt,idcum(i),k)=fxt_ddft(ixt,i,k)
	6318	fxt_fluxmasse1(ixt,idcum(i),k)=fxt_fluxmasse(ixt,i,k)
	6319	fxt_evapprecip1(ixt,idcum(i),k)=fxt_evapprecip(ixt,i,k)
	6320	enddo
	6321	enddo
	6322	enddo
	6323	do i=1,ncum
	6324	epmax_diag1(idcum(i))=epmax_diag(i)
	6325	enddo
	6326
	6327	#endif
	6328	#endif
	6329
	6330	! do 2100 j=1,ntra
	6331	! do 2110 k=1,nd ! oct3
	6332	! do 2120 i=1,ncum
	6333	! ftra1(idcum(i),k,j)=ftra(i,k,j)
	6334	! 2120 continue
	6335	! 2110 continue
	6336	! 2100 continue
	6337	DO j = 1, nd
	6338	DO k = 1, nd
	6339	DO i = 1, ncum
	6340	sij1(idcum(i), k, j) = sij(i, k, j)
	6341	phi1(idcum(i), k, j) = phi(i, k, j)
	6342	phi21(idcum(i), k, j) = phi2(i, k, j)
	6343	elij1(idcum(i), k, j) = elij(i, k, j)
	6344	epmlmmm1(idcum(i), k, j) = epmlmmm(i, k, j)
	6345	END DO
	6346	END DO
	6347	END DO
	6348
	6349	RETURN
	6350	END SUBROUTINE cv30_uncompress
	6351
	6352	subroutine cv30_epmax_fn_cape(nloc,ncum,nd &
	6353	,cape,ep,hp,icb,inb,clw,nk,t,h,lv &
	6354	,epmax_diag)
	6355	implicit none
	6356
	6357	! On fait varier epmax en fn de la cape
[4050]	6358	! Il faut donc recalculer ep, et hp qui a deja ete calcule et
	6359	! qui en depend
	6360	! Toutes les autres variables fn de ep sont calculees plus bas.
[3927]	6361
	6362	#include "cvthermo.h"
	6363	#include "cv30param.h"
	6364	#include "conema3.h"
	6365
	6366	! inputs:
	6367	integer ncum, nd, nloc
	6368	integer icb(nloc), inb(nloc)
	6369	real cape(nloc)
	6370	real clw(nloc,nd),lv(nloc,nd),t(nloc,nd),h(nloc,nd)
	6371	integer nk(nloc)
	6372	! inouts:
	6373	real ep(nloc,nd)
	6374	real hp(nloc,nd)
	6375	! outputs ou local
	6376	real epmax_diag(nloc)
	6377	! locals
	6378	integer i,k
	6379	real hp_bak(nloc,nd)
	6380	CHARACTER (LEN=20) :: modname='cv30_epmax_fn_cape'
	6381	CHARACTER (LEN=80) :: abort_message
	6382
	6383	! on recalcule ep et hp
	6384
	6385	if (coef_epmax_cape.gt.1e-12) then
	6386	do i=1,ncum
	6387	epmax_diag(i)=epmax-coef_epmax_cape*sqrt(cape(i))
	6388	do k=1,nl
	6389	ep(i,k)=ep(i,k)/epmax*epmax_diag(i)
	6390	ep(i,k)=amax1(ep(i,k),0.0)
	6391	ep(i,k)=amin1(ep(i,k),epmax_diag(i))
	6392	enddo
	6393	enddo
	6394
	6395	! On recalcule hp:
	6396	do k=1,nl
	6397	do i=1,ncum
	6398	hp_bak(i,k)=hp(i,k)
	6399	enddo
	6400	enddo
	6401	do k=1,nlp
	6402	do i=1,ncum
	6403	hp(i,k)=h(i,k)
	6404	enddo
	6405	enddo
	6406	do k=minorig+1,nl
	6407	do i=1,ncum
	6408	if((k.ge.icb(i)).and.(k.le.inb(i)))then
	6409	hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)t(i,k))ep(i,k)*clw(i,k)
	6410	endif
	6411	enddo
	6412	enddo !do k=minorig+1,n
	6413	! write(,) 'cv30_routines 6218: hp(1,20)=',hp(1,20)
	6414	do i=1,ncum
	6415	do k=1,nl
	6416	if (abs(hp_bak(i,k)-hp(i,k)).gt.0.01) then
	6417	write(,) 'i,k=',i,k
	6418	write(,) 'coef_epmax_cape=',coef_epmax_cape
	6419	write(,) 'epmax_diag(i)=',epmax_diag(i)
	6420	write(,) 'ep(i,k)=',ep(i,k)
	6421	write(,) 'hp(i,k)=',hp(i,k)
	6422	write(,) 'hp_bak(i,k)=',hp_bak(i,k)
	6423	write(,) 'h(i,k)=',h(i,k)
	6424	write(,) 'nk(i)=',nk(i)
	6425	write(,) 'h(i,nk(i))=',h(i,nk(i))
	6426	write(,) 'lv(i,k)=',lv(i,k)
	6427	write(,) 't(i,k)=',t(i,k)
	6428	write(,) 'clw(i,k)=',clw(i,k)
	6429	write(,) 'cpd,cpv=',cpd,cpv
	6430	CALL abort_physic(modname,abort_message,0)
	6431	endif
	6432	enddo !do k=1,nl
	6433	enddo !do i=1,ncum
	6434	endif !if (coef_epmax_cape.gt.1e-12) then
	6435
	6436	return
	6437	end subroutine cv30_epmax_fn_cape
	6438
	6439

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

Download in other formats:

Original Format