Context Navigation

cv30_routines.F90 @ 5453

Last change on this file since 5453 was 4368, checked in by lguez, 2 years ago
Sync latest trunk changes to Ocean_skin
Property svn:keywords set to `Id`
File size: 217.5 KB

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

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

Download in other formats:

Original Format