Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

cv3_routines.F90 @ 5434

Last change on this file since 5434 was 3331, checked in by acozic, 7 years ago
Add modification for isotopes
Property svn:executable set to ``*
File size: 231.6 KB

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

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

Download in other formats:

Original Format