Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

cv30_routines_mod.F90 @ 5454

Last change on this file since 5454 was 5283, checked in by abarral, 2 months ago
Turn tracstoke.h conema3.h cv30_routines.f90 cv30param.h into modules
Property svn:keywords set to `Id`
File size: 216.4 KB

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

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

Download in other formats:

Original Format