Context Navigation

cv30_routines.F90 @ 4050

Last change on this file since 4050 was 4050, checked in by dcugnet, 2 years ago

Second commit for new tracers.

include most of the keys in the tracers descriptor vector "tracers(:)".
fix in phylmdiso/cv3_routines: fq_* variables were used where their fxt_* counterparts were expected.
multiple IF(nqdesc(iq)>0) and IF(nqfils(iq)>0) tests suppressed, because they are not needed: "do ... enddo" loops with 0 upper bound are not executed.
remove French accents from comments (encoding problem) in phylmdiso/cv3_routines and phylmdiso/cv30_routines.
modifications in "isotopes_verif_mod", where the call to function "iso_verif_tag17_q_deltad_chn" in "iso_verif_tag17_q_deltad_chn" was not detected at linking stage, although defined in the same module (?).

Property svn:keywords set to Id

File size: 217.5 KB

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

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

Download in other formats:

Original Format