Context Navigation

cv30_routines.F90 @ 4143

Last change on this file since 4143 was 4143, checked in by dcugnet, 2 years ago
Some variables are renamed or replaced by direct equivalents: iso_indnum -> tracers(:)%iso_iName niso_possibles -> niso iqiso -> iqIsoPha ; index_trac -> itZonIso ok_iso_verif -> isoCheck ntraceurs_zone -> nzone ; ntraciso -> ntiso qperemin -> min_qparent ; masseqmin -> min_qmass ; ratiomin -> min_ratio Some renamed variables are only aliased with the older name (using USE <module>, ONLY: <oldName> => <newName>) in routines where they are repeated many times. Few hard-coded indexes are now computed (examples: ilic, iso, ivap, irneb, iq_vap, iq_liq, iso_H2O, iso_HDO, iso_HTO, iso_O17, iso_O18). The IF(isoCheck) test is now embedded in the check_isotopes_seq and check_isotopes_loc routines (lighter calling).
Property svn:keywords set to `Id`
File size: 217.5 KB

Line
1
2	! $Id: cv30_routines.F90 4143 2022-05-09 10:35:40Z 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=>ntiso
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=>ntiso
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=>ntiso
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=>ntiso
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=>ntiso,niso,itZonIso
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(itZonIso( &
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(itZonIso(
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=>ntiso
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: itZonIso
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(itZonIso(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	! : itZonIso(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	! : itZonIso(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=>ntiso, niso, nzone, itZonIso
3372	use isotopes_mod, ONLY: essai_convergence,ridicule,iso_eau,iso_HDO,iso_O18
3373	#ifdef ISOVERIF
3374	use isotopes_verif_mod, ONLY: errmax,errmaxrel, &
3375	iso_verif_egalite_choix, iso_verif_noNaN,iso_verif_aberrant, &
3376	iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
3377	iso_verif_egalite_nostop,iso_verif_aberrant_nostop,deltaD,iso_verif_noNaN_nostop, &
3378	iso_verif_positif,iso_verif_egalite_vect2D, &
3379	iso_verif_aberrant_enc_nostop,iso_verif_aberrant_encadre,iso_verif_o18_aberrant, &
3380	iso_verif_O18_aberrant_nostop,deltaO
3381	#endif
3382	#ifdef ISOTRAC
3383	use isotrac_mod, only: option_traceurs, &
3384	izone_revap,izone_poubelle,izone_ddft
3385	#ifdef ISOVERIF
3386	use isotopes_verif_mod, ONLY: iso_verif_traceur_choix_nostop,deltalimtrac, &
3387	& iso_verif_tracpos_choix_nostop,iso_verif_traceur,iso_verif_traceur_justmass
3388	use isotrac_mod, only: ridicule_trac
3389	#endif
3390	#endif
3391	#endif
3392
3393	IMPLICIT NONE
3394
3395	include "cvthermo.h"
3396	include "cv30param.h"
3397	include "cvflag.h"
3398	include "conema3.h"
3399
3400	! inputs:
3401	INTEGER ncum, nd, na, ntra, nloc
3402	INTEGER icb(nloc), inb(nloc)
3403	REAL delt
3404	REAL t(nloc, nd), rr(nloc, nd), u(nloc, nd), v(nloc, nd)
3405	REAL tra(nloc, nd, ntra), sig(nloc, nd)
3406	REAL gz(nloc, na), ph(nloc, nd+1), h(nloc, na), hp(nloc, na)
3407	REAL th(nloc, na), p(nloc, nd), tp(nloc, na)
3408	REAL lv(nloc, na), cpn(nloc, na), ep(nloc, na), clw(nloc, na)
3409	REAL m(nloc, na), mp(nloc, na), rp(nloc, na), up(nloc, na)
3410	REAL vp(nloc, na), wt(nloc, nd), trap(nloc, nd, ntra)
3411	REAL water(nloc, na), evap(nloc, na), b(nloc, na)
3412	REAL ment(nloc, na, na), qent(nloc, na, na), uent(nloc, na, na)
3413	! ym real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
3414	REAL vent(nloc, na, na), elij(nloc, na, na)
3415	INTEGER nent(nloc, na)
3416	REAL traent(nloc, na, na, ntra)
3417	REAL tv(nloc, nd), tvp(nloc, nd)
3418	#ifdef ISO
3419	real xt(ntraciso,nloc,nd)
3420	! real xtep(ntraciso,nloc,na) ! le 7 mai: on supprime xtep
3421	real xtclw(ntraciso,nloc,na), xtp(ntraciso,nloc,na)
3422	real xtwater(ntraciso,nloc,na), xtevap(ntraciso,nloc,na)
3423	real xtent(ntraciso,nloc,na,na), xtelij(ntraciso,nloc,na,na)
3424	#ifdef ISOVERIF
3425	CHARACTER (LEN=20) :: modname='cv30_compress'
3426	CHARACTER (LEN=80) :: abort_message
3427	#endif
3428	#endif
3429
3430	! input/output:
3431	INTEGER iflag(nloc)
3432
3433	! outputs:
3434	REAL precip(nloc)
3435	REAL vprecip(nloc, nd+1)
3436	REAL ft(nloc, nd), fr(nloc, nd), fu(nloc, nd), fv(nloc, nd)
3437	REAL ftra(nloc, nd, ntra)
3438	REAL upwd(nloc, nd), dnwd(nloc, nd), ma(nloc, nd)
3439	REAL dnwd0(nloc, nd), mike(nloc, nd)
3440	REAL tls(nloc, nd), tps(nloc, nd)
3441	REAL qcondc(nloc, nd) ! cld
3442	REAL wd(nloc) ! gust
3443	#ifdef ISO
3444	real xtprecip(ntraciso,nloc), fxt(ntraciso,nloc,nd)
3445	real xtVprecip(ntraciso,nloc,nd+1)
3446	#endif
3447
3448	! local variables:
3449	INTEGER i, k, il, n, j, num1
3450	REAL rat, awat, delti
3451	REAL ax, bx, cx, dx, ex
3452	REAL cpinv, rdcp, dpinv
3453	REAL lvcp(nloc, na), mke(nloc, na)
3454	REAL am(nloc), work(nloc), ad(nloc), amp1(nloc)
3455	! !! real up1(nloc), dn1(nloc)
3456	REAL up1(nloc, nd, nd), dn1(nloc, nd, nd)
3457	REAL asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
3458	REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
3459	REAL siga(nloc, nd), sax(nloc, nd), mac(nloc, nd) ! cld
3460	#ifdef ISO
3461	integer ixt
3462	real xtbx(ntraciso), xtawat(ntraciso)
3463	! cam debug
3464	! pour l'homogeneisation sous le nuage:
3465	real frsum(nloc), bxtsum(ntraciso,nloc), fxtsum(ntraciso,nloc)
3466	! correction dans calcul tendance liee a Am:
3467	real dq_tmp,k_tmp,dx_tmp,R_tmp,dqreste_tmp,dxreste_tmp,kad_tmp
3468	logical correction_excess_aberrant
3469	parameter (correction_excess_aberrant=.false.)
3470	! correction qui permettait d'eviter deltas et dexcess aberrants. Mais
3471	! pb: ne conserve pas la masse d'isotopes!
3472	#ifdef DIAGISO
3473	! diagnostiques juste: tendance des differents processus
3474	real fxt_detrainement(ntraciso,nloc,nd)
3475	real fxt_fluxmasse(ntraciso,nloc,nd)
3476	real fxt_evapprecip(ntraciso,nloc,nd)
3477	real fxt_ddft(ntraciso,nloc,nd)
3478	real fq_detrainement(nloc,nd)
3479	real q_detrainement(nloc,nd)
3480	real xt_detrainement(ntraciso,nloc,nd)
3481	real f_detrainement(nloc,nd)
3482	real fq_fluxmasse(nloc,nd)
3483	real fq_evapprecip(nloc,nd)
3484	real fq_ddft(nloc,nd)
3485	#endif
3486	!#ifdef ISOVERIF
3487	! integer iso_verif_aberrant_nostop
3488	! real deltaD
3489	!#endif
3490	#ifdef ISOTRAC
3491	! integer iso_verif_traceur_choix_nostop
3492	! integer iso_verif_tracpos_choix_nostop
3493	real xtnew(ntraciso)
3494	! real conversion(niso)
3495	real fxtYe(niso)
3496	real fxtqe(niso)
3497	real fxtXe(niso)
3498	real fxt_revap(niso)
3499	real Xe(niso)
3500	integer ixt_revap,izone
3501	integer ixt_poubelle, ixt_ddft,iiso
3502	#endif
3503	#endif
3504
3505
3506	! -------------------------------------------------------------
3507
3508	! initialization:
3509
3510	delti = 1.0/delt
3511
3512	DO il = 1, ncum
3513	precip(il) = 0.0
3514	wd(il) = 0.0 ! gust
3515	vprecip(il, nd+1) = 0.
3516	#ifdef ISO
3517	! cam debug
3518	! write(,) 'cv30_routines 3082: entree dans cv3_yield'
3519	! en cam debug
3520	do ixt = 1, ntraciso
3521	xtprecip(ixt,il)=0.0
3522	xtVprecip(ixt,il,nd+1)=0.0
3523	enddo
3524	#endif
3525	END DO
3526
3527	DO i = 1, nd
3528	DO il = 1, ncum
3529	vprecip(il, i) = 0.0
3530	ft(il, i) = 0.0
3531	fr(il, i) = 0.0
3532	fu(il, i) = 0.0
3533	fv(il, i) = 0.0
3534	qcondc(il, i) = 0.0 ! cld
3535	qcond(il, i) = 0.0 ! cld
3536	nqcond(il, i) = 0.0 ! cld
3537	#ifdef ISO
3538	do ixt = 1, ntraciso
3539	fxt(ixt,il,i)=0.0
3540	xtVprecip(ixt,il,i)=0.0
3541	enddo
3542	#ifdef DIAGISO
3543	fq_fluxmasse(il,i)=0.0
3544	fq_detrainement(il,i)=0.0
3545	f_detrainement(il,i)=0.0
3546	q_detrainement(il,i)=0.0
3547	fq_evapprecip(il,i)=0.0
3548	fq_ddft(il,i)=0.0
3549	do ixt = 1, niso
3550	fxt_fluxmasse(ixt,il,i)=0.0
3551	fxt_detrainement(ixt,il,i)=0.0
3552	xt_detrainement(ixt,il,i)=0.0
3553	fxt_evapprecip(ixt,il,i)=0.0
3554	fxt_ddft(ixt,il,i)=0.0
3555	enddo
3556	#endif
3557	#endif
3558	END DO
3559	END DO
3560
3561	! do j=1,ntra
3562	! do i=1,nd
3563	! do il=1,ncum
3564	! ftra(il,i,j)=0.0
3565	! enddo
3566	! enddo
3567	! enddo
3568
3569	DO i = 1, nl
3570	DO il = 1, ncum
3571	lvcp(il, i) = lv(il, i)/cpn(il, i)
3572	END DO
3573	END DO
3574
3575
3576
3577	! * calculate surface precipitation in mm/day *
3578
3579	DO il = 1, ncum
3580	IF (ep(il,inb(il))>=0.0001) THEN
3581	IF (cvflag_grav) THEN
3582	precip(il) = wt(il, 1)sigdwater(il, 1)86400.1000./(rowl*grav)
3583
3584	#ifdef ISO
3585	do ixt = 1, ntraciso
3586	xtprecip(ixt,il)=wt(il,1)sigdxtwater(ixt,il,1) &
3587	& 86400.1000./(rowl*grav) ! en mm/jour
3588	enddo
3589	! cam verif
3590	#ifdef ISOVERIF
3591	if (iso_eau.gt.0) then
3592	! write(,) 'cv30_yield 2952: '//
3593	! : 'il,water(il,1),xtwater(iso_eau,il,1)='
3594	! : ,il,water(il,1),xtwater(iso_eau,il,1)
3595	call iso_verif_egalite_choix(xtwater(iso_eau,il,1), &
3596	& water(il,1),'cv30_routines 2959', &
3597	& errmax,errmaxrel)
3598	!Rq: wt(il,1)sigd86400.1000./(rowlgrav)=3964.6565
3599	! -> on auatorise 3e3 fois plus d'erreur dans precip
3600	call iso_verif_egalite_choix(xtprecip(iso_eau,il), &
3601	& precip(il),'cv30_routines 3138', &
3602	& errmax*4e3,errmaxrel)
3603	endif !if (iso_eau.gt.0) then
3604	#ifdef ISOTRAC
3605	call iso_verif_traceur(xtwater(1,il,1), &
3606	& 'cv30_routine 3146')
3607	if (iso_verif_traceur_choix_nostop(xtprecip(1,il), &
3608	& 'cv30_routine 3147',errmax*1e2, &
3609	& errmaxrel,ridicule_trac,deltalimtrac).eq.1) then
3610	write(,) 'il,inb(il)=',il,inb(il)
3611	write(,) 'xtwater(:,il,1)=',xtwater(:,il,1)
3612	write(,) 'xtprecip(:,il)=',xtprecip(:,il)
3613	write(,) 'fac=',wt(il,1)sigd86400.1000./(rowlgrav)
3614	stop
3615	endif
3616	#endif
3617	#endif
3618	! end cam verif
3619	#endif
3620	ELSE
3621	precip(il) = wt(il, 1)sigdwater(il, 1)*8640.
3622	#ifdef ISO
3623	do ixt = 1, ntraciso
3624	xtprecip(ixt,il)=wt(il,1)sigdxtwater(ixt,il,1)*8640.
3625	enddo
3626	! cam verif
3627	#ifdef ISOVERIF
3628	if (iso_eau.gt.0) then
3629	call iso_verif_egalite_choix(xtprecip(iso_eau,il), &
3630	& precip(il),'cv30_routines 3139', &
3631	& errmax,errmaxrel)
3632	endif !if (iso_eau.gt.0) then
3633	#ifdef ISOTRAC
3634	call iso_verif_traceur(xtprecip(1,il),'cv30_routine 3166')
3635	#endif
3636	#endif
3637	! end cam verif
3638	#endif
3639	END IF !IF (cvflag_grav) THEN
3640	END IF !IF (cvflag_grav) THEN
3641	END DO
3642
3643	! *** CALCULATE VERTICAL PROFILE OF PRECIPITATIONs IN kg/m2/s ===
3644
3645	! MAF rajout pour lessivage
3646	DO k = 1, nl
3647	DO il = 1, ncum
3648	IF (k<=inb(il)) THEN
3649	IF (cvflag_grav) THEN
3650	vprecip(il, k) = wt(il, k)sigdwater(il, k)/grav
3651	#ifdef ISO
3652	do ixt=1,ntraciso
3653	xtVPrecip(ixt,il,k) = wt(il,k)*sigd &
3654	& *xtwater(ixt,il,k)/grav
3655	enddo
3656	#endif
3657	ELSE
3658	vprecip(il, k) = wt(il, k)sigdwater(il, k)/10.
3659	#ifdef ISO
3660	do ixt=1,ntraciso
3661	xtVPrecip(ixt,il,k) = wt(il,k)*sigd &
3662	& *xtwater(ixt,il,k)/10.0
3663	enddo
3664	#endif
3665	END IF
3666	END IF
3667	END DO
3668	END DO
3669
3670
3671	! * Calculate downdraft velocity scale *
3672	! * NE PAS UTILISER POUR L'INSTANT *
3673
3674	! ! do il=1,ncum
3675	! ! wd(il)=betadabs(mp(il,icb(il)))0.01rrdt(il,icb(il))
3676	! ! : /(sigd*p(il,icb(il)))
3677	! ! enddo
3678
3679
3680	! * calculate tendencies of lowest level potential temperature *
3681	! * and mixing ratio *
3682
3683	DO il = 1, ncum
3684	work(il) = 1.0/(ph(il,1)-ph(il,2))
3685	am(il) = 0.0
3686	END DO
3687
3688	DO k = 2, nl
3689	DO il = 1, ncum
3690	IF (k<=inb(il)) THEN
3691	am(il) = am(il) + m(il, k)
3692	END IF
3693	END DO
3694	END DO
3695
3696	DO il = 1, ncum
3697
3698	! convect3 if((0.1dpinvam).ge.delti)iflag(il)=4
3699	IF (cvflag_grav) THEN
3700	IF ((0.01gravwork(il)*am(il))>=delti) iflag(il) = 1 !consist vect
3701	ft(il, 1) = 0.01gravwork(il)am(il)(t(il,2)-t(il,1)+(gz(il,2)-gz(il, &
3702	1))/cpn(il,1))
3703	ELSE
3704	IF ((0.1work(il)am(il))>=delti) iflag(il) = 1 !consistency vect
3705	ft(il, 1) = 0.1work(il)am(il)*(t(il,2)-t(il,1)+(gz(il,2)-gz(il, &
3706	1))/cpn(il,1))
3707	END IF
3708
3709	ft(il, 1) = ft(il, 1) - 0.5lvcp(il, 1)sigd*(evap(il,1)+evap(il,2))
3710
3711	IF (cvflag_grav) THEN
3712	ft(il, 1) = ft(il, 1) - 0.009gravsigdmp(il, 2)t(il, 1)b(il, 1) &
3713	work(il)
3714	ELSE
3715	ft(il, 1) = ft(il, 1) - 0.09sigdmp(il, 2)t(il, 1)b(il, 1)*work(il)
3716	END IF
3717
3718	ft(il, 1) = ft(il, 1) + 0.01sigdwt(il, 1)(cl-cpd)water(il, 2)*(t(il,2 &
3719	)-t(il,1))*work(il)/cpn(il, 1)
3720
3721	IF (cvflag_grav) THEN
3722	! jyg1 Correction pour mieux conserver l'eau (conformite avec
3723	! CONVECT4.3)
3724	! (sb: pour l'instant, on ne fait que le chgt concernant grav, pas
3725	! evap)
3726	fr(il, 1) = 0.01gravmp(il, 2)(rp(il,2)-rr(il,1))work(il) + &
3727	sigd0.5(evap(il,1)+evap(il,2))
3728	! +tard : +sigd*evap(il,1)
3729
3730	fr(il, 1) = fr(il, 1) + 0.01gravam(il)(rr(il,2)-rr(il,1))work(il)
3731
3732	#ifdef ISO
3733	! juste Mp et evap pour l'instant, voir plus bas pour am
3734	do ixt = 1, ntraciso
3735	fxt(ixt,il,1)= &
3736	& 0.01gravmp(il,2)(xtp(ixt,il,2)-xt(ixt,il,1))work(il) &
3737	& +sigd0.5(xtevap(ixt,il,1)+xtevap(ixt,il,2))
3738	!c+tard : +sigd*xtevap(ixt,il,1)
3739	enddo !do ixt = 1, ntraciso ! pour water tagging option 6: pas besoin ici de faire de conversion.
3740
3741	#ifdef DIAGISO
3742	fq_ddft(il,1)=fq_ddft(il,1) &
3743	& +0.01gravmp(il,2)(rp(il,2)-rr(il,1))work(il)
3744	fq_evapprecip(il,1)=fq_evapprecip(il,1) &
3745	& +sigd0.5(evap(il,1)+evap(il,2))
3746	fq_fluxmasse(il,1)=fq_fluxmasse(il,1) &
3747	& +0.01gravam(il)(rr(il,2)-rr(il,1))work(il)
3748	do ixt = 1, ntraciso
3749	! fxt_fluxmasse(ixt,il,1)=fxt_fluxmasse(ixt,il,1) &
3750	! & +0.01gravam(il)(xt(ixt,il,2)-xt(ixt,il,1))work(il) ! deplace
3751	! plus haut car il existe differents cas
3752	fxt_ddft(ixt,il,1)=fxt_ddft(ixt,il,1) &
3753	& +0.01gravmp(il,2)(xtp(ixt,il,2)-xt(ixt,il,1))work(il)
3754	fxt_evapprecip(ixt,il,1)=fxt_evapprecip(ixt,il,1) &
3755	& +sigd0.5(xtevap(ixt,il,1)+xtevap(ixt,il,2))
3756	enddo
3757	#endif
3758
3759
3760	! pour l'ajout de la tendance liee au flux de masse Am, il faut etre
3761	! prudent.
3762	! On a dq1=k(q2-q1) avec k=dt0.01gravam(il)*work(il)
3763	! Pour les isotopes, la formule utilisee depuis 2006 et qui avait toujours marche est:
3764	! dx1=k*(x2-x1)
3765	! Mais on plante dans un cas pathologique en decembre 2017 lors du test
3766	! d'un cas d'Anne Cozic: les isotopes deviennent negatifs.
3767	! C'est un cas pas physique: on perd 99% de la masse de vapeur d'eau!
3768	! q2=1.01e-3 et q1=1.25e-3 kg/kg
3769	! et dq=-1.24e-3: comment est-ce possible qu'un flux venant d'un air a
3770	! q2= 1.01e-3 asseche q1 jusqu'a 0.01e-3kg/kg!
3771	! Pour les isotopes, ca donne des x1+dx negatifs.
3772	! Ce n'est pas physique mais il faut quand meme s'adapter.
3773	! Pour cela, on considere que d'abord on fait rentrer le flux de masse
3774	! descendant, et ensuite seulement on fait sortir le flux de masse
3775	! sortant.
3776	! Ainsi, le flux de masse sortant ne modifie pas la composition
3777	! isotopique de la vapeur d'eau q1.
3778	! A la fin, on a R=(x1+dx)/(q1+dq)=(x1+kx2)/(q1+kq2)
3779	! On verifie que quand k est petit, on tend vers la formulation
3780	! habituelle.
3781	! Comme on est habitues a la formulation habituelle, qu'elle a fait ses
3782	! preuves, on la garde sauf dans le cas ou dq/q<-0.9 ou on utilise la
3783	! nouvelle formulation.
3784	! rappel: dq_tmp=0.01gravam(il)(rr(il,2)-rr(il,1))work(il)*delt
3785	! Meme avec cette nouvelle foirmulation, on a encore des isotopes
3786	! negatifs, cette fois a cause des ddfts
3787	! On considere donc les tendances et serie et non en parallele quand on
3788	! calcule R_tmp.
3789	dq_tmp=0.01gravam(il)(rr(il,2)-rr(il,1))work(il)*delt ! utile ci-dessous
3790	if ((dq_tmp/rr(il,1).lt.-0.9).and.correction_excess_aberrant) then
3791	! nouvelle formulation ou on fait d'abord entrer k*q2 et ensuite
3792	! seulement on fait sortir k*q1 sans changement de composition
3793	! isotopique
3794	k_tmp=0.01gravam(il)work(il)delt
3795	dqreste_tmp= 0.01gravmp(il, 2)(rp(il,2)-rr(il,1))work(il)*delt + &
3796	& sigd0.5(evap(il,1)+evap(il,2))*delt
3797	do ixt = 1, ntraciso
3798	dxreste_tmp= 0.01gravmp(il,2)(xtp(ixt,il,2)-xt(ixt,il,1))work(il)*delt &
3799	& +sigd0.5(xtevap(ixt,il,1)+xtevap(ixt,il,2))*delt
3800	R_tmp=(xt(ixt,il,1)+dxreste_tmp+k_tmpxt(ixt,il,2))/(rr(il,1)+dqreste_tmp+k_tmprr(il,2))
3801	dx_tmp=R_tmp*(rr(il,1)+dqreste_tmp+dq_tmp)-(xt(ixt,il,1)+dxreste_tmp)
3802	fxt(ixt,il,1)=fxt(ixt,il,1) &
3803	& + dx_tmp/delt
3804	#ifdef ISOVERIF
3805	if (ixt.eq.iso_HDO) then
3806	write(,) 'cv30_routines 3888: il=',il
3807	write(,) 'dq_tmp,rr(il,1)=',dq_tmp,rr(il,1)
3808	write(,) 'R_tmp,dx_tmp,delt=',R_tmp,dx_tmp,delt
3809	write(,) 'xt(ixt,il,1:2)=',xt(ixt,il,1:2)
3810	write(,) 'rr(il,1:2)=',rr(il,1:2)
3811	write(,) 'fxt=',dx_tmp/delt
3812	write(,) 'rr(il,1)+dq_tmp=',rr(il,1)+dq_tmp
3813	write(,) 'xt(ixt,il,1)+dx_tmp=',xt(ixt,il,1)+dx_tmp
3814	write(,) 'xt(ixt,il,1)+fxt(ixt,il,1)*delt=', &
3815	& xt(ixt,il,1)+fxt(ixt,il,1)*delt
3816	write(,) 'dqreste_tmp,dxreste_tmp=',dqreste_tmp,dxreste_tmp
3817	write(,) 'formule classique: fxt_Am=',0.01gravam(il)(xt(ixt,il,2)-xt(ixt,il,1))work(il)
3818	write(,) 'donnerait dxt=',0.01gravam(il)(xt(ixt,il,2)-xt(ixt,il,1))work(il)*delt
3819	endif !if (ixt.eq.iso_HDO) then
3820	#endif
3821	#ifdef DIAGISO
3822	if (ixt.le.niso) then
3823	fxt_fluxmasse(ixt,il,1)=fxt_fluxmasse(ixt,il,1) &
3824	& + dx_tmp/delt
3825	endif
3826	#endif
3827	enddo ! do ixt = 1, ntraciso
3828	else !if (dq_tmp/rr(il,1).lt.-0.9) then
3829	! formulation habituelle qui avait toujours marche de 2006 a
3830	! decembre 2017.
3831	do ixt = 1, ntraciso
3832	fxt(ixt,il,1)=fxt(ixt,il,1) &
3833	& +0.01gravam(il)(xt(ixt,il,2)-xt(ixt,il,1))work(il)
3834	#ifdef DIAGISO
3835	if (ixt.le.niso) then
3836	fxt_fluxmasse(ixt,il,1)=fxt_fluxmasse(ixt,il,1) &
3837	& +0.01gravam(il)(xt(ixt,il,2)-xt(ixt,il,1))work(il)
3838	endif
3839	#endif
3840	enddo !do ixt = 1, ntraciso
3841	endif !if (dq_tmp/rr(il,1).lt.-0.9) then
3842
3843	! cam verif
3844	#ifdef ISOVERIF
3845	if (iso_eau.gt.0) then
3846	call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
3847	& fr(il,1),'cv30_routines 3251', &
3848	& errmax,errmaxrel)
3849	endif !if (iso_eau.gt.0) then
3850	!write(,) 'il,am(il)=',il,am(il)
3851	if ((iso_HDO.gt.0).and. &
3852	& (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
3853	if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,1) &
3854	& +deltfxt(iso_HDO,il,1))/(rr(il,1)+deltfr(il,1)), &
3855	& 'cv30_yield 3125, ddft en 1').eq.1) then
3856	write(,) 'il,rr(il,1),delt=',il,rr(il,1),delt
3857	write(,) 'deltaDxt=',deltaD(xt(iso_HDO,il,1)/rr(il,1))
3858	write(,) 'deltfr(il,1),fr(il,1)=',deltfr(il,1),fr(il,1)
3859	write(,) 'fxt=',fxt(iso_HDO,il,1)
3860	write(,) 'fq_ddft(il,1)=',0.01gravmp(il,2)(rp(il,2)-rr(il,1))work(il)
3861	write(,) 'fq_evapprecip(il,1)=',sigd0.5(evap(il,1)+evap(il,2))
3862	write(,) 'fq_fluxmasse(il,1)=', 0.01gravam(il)(rr(il,2)-rr(il,1))work(il)
3863	write(,) 'deltaDfq_ddft=',deltaD((xtp(iso_HDO,il,2)-xt(iso_HDO,il,1))/(rp(il,2)-rr(il,1)))
3864	write(,) 'deltaDfq_evapprecip=',deltaD((xtevap(iso_HDO,il,1)+xtevap(iso_HDO,il,2))/(evap(il,1)+evap(il,2)))
3865	write(,) 'deltaDfq_fluxmasse=',deltaD((xt(iso_HDO,il,2)-xt(iso_HDO,il,1))/(rr(il,2)-rr(il,1)))
3866	write(,) 'rr(il,2),rr(il,1)=',rr(il,2),rr(il,1)
3867	write(,) 'xt(iso_HDO,il,2),xt(iso_HDO,il,1)',xt(iso_HDO,il,2),xt(iso_HDO,il,1)
3868	write(,) 'dq_tmp=',dq_tmp
3869	call abort_physic('cv30_routines','cv30_yield',1)
3870	endif ! iso_verif_aberrant_enc_nostop
3871	endif !if (iso_HDO.gt.0) then
3872	#ifdef ISOTRAC
3873	call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3417')
3874	do ixt=1,ntraciso
3875	xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
3876	enddo
3877	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3395',1e-5) &
3878	& .eq.1) then
3879	write(,) 'il=',il
3880	write(,) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
3881	write(,) 'xt(:,il,1)=' ,xt(:,il,1)
3882	#ifdef DIAGISO
3883	write(,) 'fxt_fluxmasse(:,il,1)=',fxt_fluxmasse(:,il,1)
3884	write(,) 'fxt_ddft(:,il,1)=',fxt_ddft(:,il,1)
3885	write(,) 'fxt_evapprecip(:,il,1)=', &
3886	& fxt_evapprecip(:,il,1)
3887	write(,) 'xt(:,il,2)=',xt(:,il,2)
3888	write(,) 'xtp(:,il,2)=',xtp(:,il,2)
3889	write(,) 'xtevap(:,il,1)=',xtevap(:,il,1)
3890	write(,) 'xtevap(:,il,2)=',xtevap(:,il,2)
3891	write(,) 'facam,facmp,facev=',0.01gravam(il)*work(il), &
3892	& 0.01gravmp(il,2)work(il),sigd0.5
3893	#endif
3894	! stop
3895	endif
3896	#endif
3897	#endif
3898	! end cam verif
3899	#endif
3900
3901	fu(il, 1) = fu(il, 1) + 0.01gravwork(il)(mp(il,2)(up(il,2)-u(il, &
3902	1))+am(il)*(u(il,2)-u(il,1)))
3903	fv(il, 1) = fv(il, 1) + 0.01gravwork(il)(mp(il,2)(vp(il,2)-v(il, &
3904	1))+am(il)*(v(il,2)-v(il,1)))
3905	ELSE ! cvflag_grav
3906	fr(il, 1) = 0.1mp(il, 2)(rp(il,2)-rr(il,1))*work(il) + &
3907	sigd0.5(evap(il,1)+evap(il,2))
3908	fr(il, 1) = fr(il, 1) + 0.1am(il)(rr(il,2)-rr(il,1))*work(il)
3909
3910
3911	#ifdef ISO
3912	do ixt = 1, ntraciso
3913	fxt(ixt,il,1)=0.1mp(il,2)(xtp(ixt,il,2)-xt(ixt,il,1))*work(il) &
3914	& +sigd0.5(xtevap(ixt,il,1)+xtevap(ixt,il,2))
3915	fxt(ixt,il,1)=fxt(ixt,il,1) &
3916	& +0.1am(il)(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
3917	enddo
3918
3919	#ifdef DIAGISO
3920	fq_ddft(il,1)=fq_ddft(il,1) &
3921	& +0.1mp(il,2)(rp(il,2)-rr(il,1))*work(il)
3922	fq_evapprecip(il,1)=fq_evapprecip(il,1) &
3923	& +sigd0.5(evap(il,1)+evap(il,2))
3924	fq_fluxmasse(il,1)=fq_fluxmasse(il,1) &
3925	& +0.1am(il)(rr(il,2)-rr(il,1))*work(il)
3926	do ixt = 1, niso
3927	fxt_fluxmasse(ixt,il,1)=fxt(ixt,il,1) &
3928	& +0.1am(il)(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
3929	fxt_ddft(ixt,il,1)=fxt(ixt,il,1) &
3930	& +0.1mp(il,2)(xtp(ixt,il,2)-xt(ixt,il,1))*work(il)
3931	fxt_evapprecip(ixt,il,1)=fxt(ixt,il,1) &
3932	& +sigd0.5(xtevap(ixt,il,1)+xtevap(ixt,il,2))
3933	enddo
3934	#endif
3935
3936
3937	! cam verif
3938	#ifdef ISOVERIF
3939	if (iso_eau.gt.0) then
3940	call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
3941	& fr(il,1),'cv30_routines 3023', &
3942	& errmax,errmaxrel)
3943	endif !if (iso_eau.gt.0) then
3944	if ((iso_HDO.gt.0).and. &
3945	& (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
3946	call iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
3947	& +delt*fxt(iso_HDO,il,1)) &
3948	& /(rr(il,1)+delt*fr(il,1)), &
3949	& 'cv30_yield 3125b, ddft en 1')
3950	endif !if (iso_HDO.gt.0) then
3951	#ifdef ISOTRAC
3952	call iso_verif_traceur_justmass(fxt(1,il,1), &
3953	& 'cv30_routine 3417')
3954	do ixt=1,ntraciso
3955	xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
3956	enddo
3957	if (iso_verif_tracpos_choix_nostop(xtnew, &
3958	& 'cv30_yield 3449',1e-5) &
3959	& .eq.1) then
3960	write(,) 'il=',il
3961	write(,) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
3962	write(,) 'xt(:,il,1)=' ,xt(:,il,1)
3963	! stop
3964	endif
3965	#endif
3966	#endif
3967	! end cam verif
3968	#endif
3969	fu(il, 1) = fu(il, 1) + 0.1work(il)(mp(il,2)*(up(il,2)-u(il, &
3970	1))+am(il)*(u(il,2)-u(il,1)))
3971	fv(il, 1) = fv(il, 1) + 0.1work(il)(mp(il,2)*(vp(il,2)-v(il, &
3972	1))+am(il)*(v(il,2)-v(il,1)))
3973	END IF ! cvflag_grav
3974
3975	END DO ! il
3976
3977	! do j=1,ntra
3978	! do il=1,ncum
3979	! if (cvflag_grav) then
3980	! ftra(il,1,j)=ftra(il,1,j)+0.01gravwork(il)
3981	! : (mp(il,2)(trap(il,2,j)-tra(il,1,j))
3982	! : +am(il)*(tra(il,2,j)-tra(il,1,j)))
3983	! else
3984	! ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
3985	! : (mp(il,2)(trap(il,2,j)-tra(il,1,j))
3986	! : +am(il)*(tra(il,2,j)-tra(il,1,j)))
3987	! endif
3988	! enddo
3989	! enddo
3990
3991	DO j = 2, nl
3992	DO il = 1, ncum
3993	IF (j<=inb(il)) THEN
3994	IF (cvflag_grav) THEN
3995	fr(il, 1) = fr(il, 1) + 0.01gravwork(il)ment(il, j, 1)(qent(il, &
3996	j,1)-rr(il,1))
3997	fu(il, 1) = fu(il, 1) + 0.01gravwork(il)ment(il, j, 1)(uent(il, &
3998	j,1)-u(il,1))
3999	fv(il, 1) = fv(il, 1) + 0.01gravwork(il)ment(il, j, 1)(vent(il, &
4000	j,1)-v(il,1))
4001
4002	#ifdef ISO
4003	do ixt = 1, ntraciso
4004	fxt(ixt,il,1)=fxt(ixt,il,1) &
4005	& +0.01gravwork(il)ment(il,j,1)(xtent(ixt,il,j,1)-xt(ixt,il,1))
4006	enddo
4007
4008	#ifdef DIAGISO
4009	fq_detrainement(il,1)=fq_detrainement(il,1) &
4010	& +0.01gravwork(il)ment(il,j,1)(qent(il,j,1)-rr(il,1))
4011	f_detrainement(il,1)=f_detrainement(il,1) &
4012	& +0.01gravwork(il)*ment(il,j,1)
4013	q_detrainement(il,1)=q_detrainement(il,1) &
4014	& +0.01gravwork(il)ment(il,j,1)qent(il,j,1)
4015	do ixt = 1, niso
4016	fxt_detrainement(ixt,il,1)=fxt_detrainement(ixt,il,1) &
4017	& +0.01gravwork(il)ment(il,j,1)(xtent(ixt,il,j,1)-xt(ixt,il,1))
4018	xt_detrainement(ixt,il,1)=xt_detrainement(ixt,il,1) &
4019	& +0.01gravwork(il)ment(il,j,1)xtent(ixt,il,j,1)
4020	enddo
4021	#endif
4022
4023	! cam verif
4024	#ifdef ISOVERIF
4025	if (iso_eau.gt.0) then
4026	call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
4027	& fr(il,1),'cv30_routines 3251',errmax,errmaxrel)
4028	endif !if (iso_eau.gt.0) then
4029	if ((iso_HDO.gt.0).and. &
4030	& (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
4031	call iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
4032	& +deltfxt(iso_HDO,il,1))/(rr(il,1)+deltfr(il,1)), &
4033	& 'cv30_yield 3127, dtr melanges')
4034	endif !if (iso_HDO.gt.0) then
4035	#ifdef ISOTRAC
4036	call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3417')
4037	do ixt=1,ntraciso
4038	xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
4039	enddo
4040	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3525',1e-5) &
4041	& .eq.1) then
4042	write(,) 'il=',il
4043	write(,) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
4044	write(,) 'fac=', 0.01gravwork(il)*ment(il,j,1)
4045	write(,) 'xt(:,il,1)=' ,xt(:,il,1)
4046	write(,) 'xtent(:,il,j,1)=' ,xtent(:,il,j,1)
4047	! stop
4048	endif
4049	#endif
4050	#endif
4051	! end cam verif
4052	#endif
4053
4054	ELSE ! cvflag_grav
4055	fr(il, 1) = fr(il, 1) + 0.1work(il)ment(il, j, 1)*(qent(il,j,1)- &
4056	rr(il,1))
4057	fu(il, 1) = fu(il, 1) + 0.1work(il)ment(il, j, 1)*(uent(il,j,1)-u &
4058	(il,1))
4059	fv(il, 1) = fv(il, 1) + 0.1work(il)ment(il, j, 1)*(vent(il,j,1)-v &
4060	(il,1))
4061
4062	#ifdef ISO
4063	do ixt = 1, ntraciso
4064	fxt(ixt,il,1)=fxt(ixt,il,1) &
4065	& +0.1work(il)ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
4066	enddo
4067
4068	#ifdef DIAGISO
4069	fq_detrainement(il,1)=fq_detrainement(il,1) &
4070	& +0.1work(il)ment(il,j,1)*(qent(il,j,1)-rr(il,1))
4071	f_detrainement(il,1)=f_detrainement(il,1) &
4072	& +0.1work(il)ment(il,j,1)
4073	q_detrainement(il,1)=q_detrainement(il,1) &
4074	& +0.1work(il)ment(il,j,1)*qent(il,j,1)
4075	do ixt = 1, niso
4076	fxt_detrainement(ixt,il,1)=fxt_detrainement(ixt,il,1) &
4077	& +0.1work(il)ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
4078	xt_detrainement(ixt,il,1)=xt_detrainement(ixt,il,1) &
4079	& +0.1work(il)ment(il,j,1)*xtent(ixt,il,j,1)
4080	enddo
4081	#endif
4082
4083	! cam verif
4084	#ifdef ISOVERIF
4085	if (iso_eau.gt.0) then
4086	call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
4087	& fr(il,1),'cv30_routines 3092',errmax,errmaxrel)
4088	endif !if (iso_eau.gt.0) then
4089	if ((iso_HDO.gt.0).and. &
4090	& (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
4091	call iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
4092	& +deltfxt(iso_HDO,il,1))/(rr(il,1)+deltfr(il,1)), &
4093	& 'cv30_yield 3127b, dtr melanges')
4094	endif !if (iso_HDO.gt.0) then
4095	#ifdef ISOTRAC
4096	call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3462')
4097	do ixt=1,ntraciso
4098	xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
4099	enddo
4100	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3753',1e-5) &
4101	& .eq.1) then
4102	write(,) 'il=',il
4103	endif
4104	#endif
4105	#endif
4106	! end cam verif
4107	#endif
4108
4109	END IF ! cvflag_grav
4110	END IF ! j
4111	END DO
4112	END DO
4113
4114	! do k=1,ntra
4115	! do j=2,nl
4116	! do il=1,ncum
4117	! if (j.le.inb(il)) then
4118
4119	! if (cvflag_grav) then
4120	! ftra(il,1,k)=ftra(il,1,k)+0.01gravwork(il)*ment(il,j,1)
4121	! : *(traent(il,j,1,k)-tra(il,1,k))
4122	! else
4123	! ftra(il,1,k)=ftra(il,1,k)+0.1work(il)ment(il,j,1)
4124	! : *(traent(il,j,1,k)-tra(il,1,k))
4125	! endif
4126
4127	! endif
4128	! enddo
4129	! enddo
4130	! enddo
4131
4132
4133	! * calculate tendencies of potential temperature and mixing ratio *
4134	! * at levels above the lowest level *
4135
4136	! * first find the net saturated updraft and downdraft mass fluxes *
4137	! * through each level *
4138
4139
4140	DO i = 2, nl + 1 ! newvecto: mettre nl au lieu nl+1?
4141
4142	num1 = 0
4143	DO il = 1, ncum
4144	IF (i<=inb(il)) num1 = num1 + 1
4145	END DO
4146	IF (num1<=0) GO TO 500
4147
4148	CALL zilch(amp1, ncum)
4149	CALL zilch(ad, ncum)
4150
4151	DO k = i + 1, nl + 1
4152	DO il = 1, ncum
4153	IF (i<=inb(il) .AND. k<=(inb(il)+1)) THEN
4154	amp1(il) = amp1(il) + m(il, k)
4155	END IF
4156	END DO
4157	END DO
4158
4159	DO k = 1, i
4160	DO j = i + 1, nl + 1
4161	DO il = 1, ncum
4162	IF (i<=inb(il) .AND. j<=(inb(il)+1)) THEN
4163	amp1(il) = amp1(il) + ment(il, k, j)
4164	END IF
4165	END DO
4166	END DO
4167	END DO
4168
4169	DO k = 1, i - 1
4170	DO j = i, nl + 1 ! newvecto: nl au lieu nl+1?
4171	DO il = 1, ncum
4172	IF (i<=inb(il) .AND. j<=inb(il)) THEN
4173	ad(il) = ad(il) + ment(il, j, k)
4174	END IF
4175	END DO
4176	END DO
4177	END DO
4178
4179	DO il = 1, ncum
4180	IF (i<=inb(il)) THEN
4181	dpinv = 1.0/(ph(il,i)-ph(il,i+1))
4182	cpinv = 1.0/cpn(il, i)
4183
4184	! convect3 if((0.1dpinvamp1).ge.delti)iflag(il)=4
4185	IF (cvflag_grav) THEN
4186	IF ((0.01gravdpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
4187	ELSE
4188	IF ((0.1dpinvamp1(il))>=delti) iflag(il) = 1 ! vecto
4189	END IF
4190
4191	IF (cvflag_grav) THEN
4192	ft(il, i) = 0.01gravdpinv(amp1(il)(t(il,i+1)-t(il, &
4193	i)+(gz(il,i+1)-gz(il,i))cpinv)-ad(il)(t(il,i)-t(il, &
4194	i-1)+(gz(il,i)-gz(il,i-1))cpinv)) - 0.5sigdlvcp(il, i)(evap( &
4195	il,i)+evap(il,i+1))
4196	rat = cpn(il, i-1)*cpinv
4197	ft(il, i) = ft(il, i) - 0.009gravsigd(mp(il,i+1)t(il,i)*b(il,i) &
4198	-mp(il,i)t(il,i-1)ratb(il,i-1))dpinv
4199	ft(il, i) = ft(il, i) + 0.01gravdpinvment(il, i, i)(hp(il,i)-h( &
4200	il,i)+t(il,i)(cpv-cpd)(rr(il,i)-qent(il,i,i)))*cpinv
4201	ELSE ! cvflag_grav
4202	ft(il, i) = 0.1dpinv(amp1(il)*(t(il,i+1)-t(il, &
4203	i)+(gz(il,i+1)-gz(il,i))cpinv)-ad(il)(t(il,i)-t(il, &
4204	i-1)+(gz(il,i)-gz(il,i-1))cpinv)) - 0.5sigdlvcp(il, i)(evap( &
4205	il,i)+evap(il,i+1))
4206	rat = cpn(il, i-1)*cpinv
4207	ft(il, i) = ft(il, i) - 0.09sigd(mp(il,i+1)t(il,i)b(il,i)-mp(il &
4208	,i)t(il,i-1)ratb(il,i-1))dpinv
4209	ft(il, i) = ft(il, i) + 0.1dpinvment(il, i, i)*(hp(il,i)-h(il,i)+ &
4210	t(il,i)(cpv-cpd)(rr(il,i)-qent(il,i,i)))*cpinv
4211	END IF ! cvflag_grav
4212
4213
4214	ft(il, i) = ft(il, i) + 0.01sigdwt(il, i)(cl-cpd)water(il, i+1)*( &
4215	t(il,i+1)-t(il,i))dpinvcpinv
4216
4217	IF (cvflag_grav) THEN
4218	fr(il, i) = 0.01gravdpinv(amp1(il)(rr(il,i+1)-rr(il, &
4219	i))-ad(il)*(rr(il,i)-rr(il,i-1)))
4220	fu(il, i) = fu(il, i) + 0.01gravdpinv(amp1(il)(u(il,i+1)-u(il, &
4221	i))-ad(il)*(u(il,i)-u(il,i-1)))
4222	fv(il, i) = fv(il, i) + 0.01gravdpinv(amp1(il)(v(il,i+1)-v(il, &
4223	i))-ad(il)*(v(il,i)-v(il,i-1)))
4224
4225	#ifdef ISO
4226	#ifdef DIAGISO
4227	fq_fluxmasse(il,i)=fq_fluxmasse(il,i) &
4228	& +0.01gravdpinv(amp1(il)(rr(il,i+1)-rr(il,i)) &
4229	& -ad(il)*(rr(il,i)-rr(il,i-1)))
4230	! modif 2 fev: pour avoir subsidence compensatoire totale, on retranche
4231	! ad.
4232	#endif
4233	! ici, on separe 2 cas, pour eviter le cas pathologique decrit plus haut
4234	! pour la tendance liee a Am en i=1, qui peut conduire a des isotopes
4235	! negatifs dans les cas ou les flux de masse soustrait plus de 90% de la
4236	! vapeur de la couche. Voir plus haut le detail des equations.
4237	! La difference ici est qu'on considere les flux de masse amp1 et ad en
4238	! meme temps.
4239	dq_tmp= 0.01gravdpinv(amp1(il)(rr(il,i+1)-rr(il,i)) &
4240	& -ad(il)(rr(il,i)-rr(il,i-1)))delt
4241	! c'est equivalent a dqi= kamp1qip1+kadqim1-(kamp1+kad)*qi
4242	if ((dq_tmp/rr(il,i).lt.-0.9).and.correction_excess_aberrant) then
4243	! nouvelle formulation
4244	k_tmp=0.01gravdpinvamp1(il)delt
4245	kad_tmp=0.01gravdpinvad(il)delt
4246	do ixt = 1, ntraciso
4247	R_tmp=(xt(ixt,il,i)+k_tmpxt(ixt,il,i+1)+kad_tmpxt(ixt,il,i-1)) &
4248	& /(rr(il,i)+k_tmprr(il,i+1)+kad_tmprr(il,i-1))
4249	dx_tmp= R_tmp*( rr(il,i)+ dq_tmp)-xt(ixt,il,i)
4250	fxt(ixt,il,i)= dx_tmp/delt
4251	#ifdef ISOVERIF
4252	if ((ixt.eq.iso_HDO).or.(ixt.eq.iso_eau)) then
4253	write(,) 'cv30_routines 4367: il,i,ixt=',il,i,ixt
4254	write(,) 'dq_tmp,rr(il,i)=',dq_tmp,rr(il,i)
4255	write(,) 'R_tmp,dx_tmp,delt=',R_tmp,dx_tmp,delt
4256	write(,) 'amp1(il),ad(il)=',amp1(il),ad(il)
4257	write(,) 'xt(ixt,il,i-1:i+1)=',xt(ixt,il,i-1:i+1)
4258	write(,) 'rr(il,i-1:i+1)=',rr(il,i-1:i+1)
4259	write(,) 'fxt=',dx_tmp/delt
4260	write(,) 'rr(il,i)+dq_tmp=',rr(il,1)+dq_tmp
4261	write(,) 'xt(ixt,il,i)+dx_tmp=',xt(ixt,il,i)+dx_tmp
4262	write(,) 'xt(ixt,il,i)+fxt(ixt,il,i)*delt=', &
4263	& xt(ixt,il,i)+fxt(ixt,il,i)*delt
4264	write(,) 'fxt(:,il,i)=',fxt(:,il,i)
4265	endif !if (ixt.eq.iso_HDO) then
4266	#endif
4267	enddo ! do ixt = 1, ntraciso
4268	#ifdef DIAGISO
4269	do ixt = 1, niso
4270	fxt_fluxmasse(ixt,il,i)=fxt(ixt,il,i)
4271	enddo
4272	#endif
4273	else !if (dq_tmp/rr(il,i).lt.-0.9) then
4274	! ancienne formulation
4275	do ixt = 1, ntraciso
4276	fxt(ixt,il,i)= &
4277	& 0.01gravdpinv(amp1(il)(xt(ixt,il,i+1)-xt(ixt,il,i)) &
4278	& -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
4279	enddo
4280	#ifdef DIAGISO
4281	do ixt = 1, niso
4282	fxt_fluxmasse(ixt,il,i)=fxt_fluxmasse(ixt,il,i)+ &
4283	& 0.01gravdpinv(amp1(il)(xt(ixt,il,i+1)-xt(ixt,il,i)) &
4284	& -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
4285	enddo
4286	#endif
4287	endif !if (dq_tmp/rr(il,i).lt.-0.9) then
4288
4289
4290	! cam verif
4291	#ifdef ISOVERIF
4292	if (iso_eau.gt.0) then
4293	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
4294	& fr(il,i),'cv30_routines 3226',errmax,errmaxrel)
4295	endif !if (iso_eau.gt.0) then
4296	do ixt=1,niso
4297	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3229')
4298	enddo
4299	if ((iso_HDO.gt.0).and. &
4300	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
4301	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
4302	& +delt*fxt(iso_HDO,il,i)) &
4303	& /(rr(il,i)+delt*fr(il,i)), &
4304	& 'cv30_yield 3384, flux masse')
4305	endif !if (iso_HDO.gt.0) then
4306	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
4307	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
4308	call iso_verif_O18_aberrant( &
4309	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
4310	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
4311	& 'cv30_yield 3384,O18, flux masse')
4312	endif !if (iso_HDO.gt.0) then
4313	#ifdef ISOTRAC
4314	call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3626')
4315	do ixt=1,ntraciso
4316	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
4317	enddo
4318	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3727',1e-5) &
4319	& .eq.1) then
4320	write(,) 'il,i=',il,i
4321	write(,) 'fxt(:,il,i)=',fxt(:,il,i)
4322	write(,) 'amp1(il),ad(il),fac=', &
4323	& amp1(il),ad(il),0.01gravdpinv
4324	write(,) 'xt(:,il,i+1)=' ,xt(:,il,i+1)
4325	write(,) 'xt(:,il,i)=' ,xt(:,il,i)
4326	write(,) 'xt(:,il,i-1)=' ,xt(:,il,i-1)
4327	! stop
4328	endif
4329	#endif
4330	#endif
4331	! end cam verif
4332	#endif
4333	ELSE ! cvflag_grav
4334	fr(il, i) = 0.1dpinv(amp1(il)*(rr(il,i+1)-rr(il, &
4335	i))-ad(il)*(rr(il,i)-rr(il,i-1)))
4336	fu(il, i) = fu(il, i) + 0.1dpinv(amp1(il)*(u(il,i+1)-u(il, &
4337	i))-ad(il)*(u(il,i)-u(il,i-1)))
4338	fv(il, i) = fv(il, i) + 0.1dpinv(amp1(il)*(v(il,i+1)-v(il, &
4339	i))-ad(il)*(v(il,i)-v(il,i-1)))
4340
4341	#ifdef ISO
4342	do ixt = 1, ntraciso
4343	fxt(ixt,il,i)= &
4344	& 0.1dpinv(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
4345	& -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
4346	enddo
4347
4348	#ifdef DIAGISO
4349	fq_fluxmasse(il,i)=fq_fluxmasse(il,i) &
4350	& +0.1dpinv(amp1(il)*(rr(il,i+1)-rr(il,i)) &
4351	& -ad(il)*(rr(il,i)-rr(il,i-1)))
4352	do ixt = 1, niso
4353	fxt_fluxmasse(ixt,il,i)=fxt_fluxmasse(ixt,il,i)+ &
4354	& 0.1dpinv(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
4355	& -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
4356	enddo
4357	#endif
4358
4359	! cam verif
4360	#ifdef ISOVERIF
4361	if (iso_eau.gt.0) then
4362	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
4363	& fr(il,i),'cv30_routines 3252',errmax,errmaxrel)
4364	endif !if (iso_eau.gt.0) then
4365	do ixt=1,niso
4366	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3229')
4367	enddo
4368	! correction 21 oct 2008
4369	if ((iso_HDO.gt.0).and. &
4370	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
4371	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
4372	& +deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
4373	& 'cv30_yield 3384b flux masse')
4374	if (iso_O18.gt.0) then
4375	call iso_verif_O18_aberrant( &
4376	& (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
4377	& /(rr(il,i)+delt*fr(il,i)), &
4378	& (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
4379	& /(rr(il,i)+delt*fr(il,i)), &
4380	& 'cv30_yield 3384bO18 flux masse')
4381	endif !if (iso_O18.gt.0) then
4382	endif !if (iso_HDO.gt.0) then
4383	#ifdef ISOTRAC
4384	call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3674')
4385	do ixt=1,ntraciso
4386	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
4387	enddo
4388	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3775',1e-5) &
4389	& .eq.1) then
4390	write(,) 'il,i=',il,i
4391	endif
4392	#endif
4393	#endif
4394	! end cam verif
4395	#endif
4396	END IF ! cvflag_grav
4397
4398	END IF ! i
4399	END DO
4400
4401	! do k=1,ntra
4402	! do il=1,ncum
4403	! if (i.le.inb(il)) then
4404	! dpinv=1.0/(ph(il,i)-ph(il,i+1))
4405	! cpinv=1.0/cpn(il,i)
4406	! if (cvflag_grav) then
4407	! ftra(il,i,k)=ftra(il,i,k)+0.01gravdpinv
4408	! : (amp1(il)(tra(il,i+1,k)-tra(il,i,k))
4409	! : -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
4410	! else
4411	! ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
4412	! : (amp1(il)(tra(il,i+1,k)-tra(il,i,k))
4413	! : -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
4414	! endif
4415	! endif
4416	! enddo
4417	! enddo
4418
4419	DO k = 1, i - 1
4420	DO il = 1, ncum
4421	IF (i<=inb(il)) THEN
4422	dpinv = 1.0/(ph(il,i)-ph(il,i+1))
4423	cpinv = 1.0/cpn(il, i)
4424
4425	awat = elij(il, k, i) - (1.-ep(il,i))*clw(il, i)
4426	awat = amax1(awat, 0.0)
4427
4428	#ifdef ISO
4429	! on change le traitement de cette ligne le 8 mai 2009:
4430	! avant, on avait: xtawat=xtelij(il,k,i)-(1.-xtep(il,i))*xtclw(il,i)
4431	! c'est a dire que Rawat=Relij+(1-ep)clw/awat(Relij-Rclw)
4432	! si Relij!=Rclw, alors un fractionnement isotopique non physique etait
4433	! introduit.
4434	! En fait, awat represente le surplus de condensat dans le melange par
4435	! rapport a celui restant dans la colonne adiabatique
4436	! ce surplus a la meme compo que le elij, sans fractionnement.
4437	! d'ou le nouveau traitement ci-dessous.
4438	if (elij(il,k,i).gt.0.0) then
4439	do ixt = 1, ntraciso
4440	xtawat(ixt)=awat*(xtelij(ixt,il,k,i)/elij(il,k,i))
4441	! xtawat(ixt)=amax1(xtawat(ixt),0.0) ! pas necessaire
4442	enddo
4443	else !if (elij(il,k,i).gt.0.0) then
4444	! normalement, si elij(il,k,i)<=0, alors awat=0
4445	! on le verifie. Si c'est vrai -> xtawat=0 aussi
4446	#ifdef ISOVERIF
4447	call iso_verif_egalite(awat,0.0,'cv30_yield 3779')
4448	#endif
4449	do ixt = 1, ntraciso
4450	xtawat(ixt)=0.0
4451	enddo
4452	endif
4453
4454	! cam verif
4455	#ifdef ISOVERIF
4456	if (iso_eau.gt.0) then
4457	call iso_verif_egalite_choix(xtawat(iso_eau), &
4458	& awat,'cv30_routines 3301',errmax,errmaxrel)
4459	endif !if (iso_eau.gt.0) then
4460	#ifdef ISOTRAC
4461	call iso_verif_traceur_justmass(xtawat(1),'cv30_routine 3729')
4462	#endif
4463	#endif
4464	! end cam verif
4465	#endif
4466
4467	IF (cvflag_grav) THEN
4468	fr(il, i) = fr(il, i) + 0.01gravdpinvment(il, k, i)(qent(il,k &
4469	,i)-awat-rr(il,i))
4470	fu(il, i) = fu(il, i) + 0.01gravdpinvment(il, k, i)(uent(il,k &
4471	,i)-u(il,i))
4472	fv(il, i) = fv(il, i) + 0.01gravdpinvment(il, k, i)(vent(il,k &
4473	,i)-v(il,i))
4474
4475	#ifdef ISO
4476	do ixt = 1, ntraciso
4477	fxt(ixt,il,i)=fxt(ixt,il,i) &
4478	& +0.01gravdpinv*ment(il,k,i) &
4479	& *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
4480	enddo
4481
4482	#ifdef DIAGISO
4483	fq_detrainement(il,i)=fq_detrainement(il,i) &
4484	& +0.01gravdpinv*ment(il,k,i) &
4485	& *(qent(il,k,i)-awat-rr(il,i))
4486	f_detrainement(il,i)=f_detrainement(il,i)&
4487	& +0.01gravdpinv*ment(il,k,i)
4488	q_detrainement(il,i)=q_detrainement(il,i) &
4489	& +0.01gravdpinvment(il,k,i)qent(il,k,i)
4490	do ixt = 1, niso
4491	fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
4492	& +0.01gravdpinv*ment(il,k,i) &
4493	& *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
4494	xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
4495	& +0.01gravdpinvment(il,k,i)xtent(ixt,il,k,i)
4496	enddo
4497	#endif
4498	! cam verif
4499	#ifdef ISOVERIF
4500	if (iso_eau.gt.0) then
4501	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
4502	& fr(il,i),'cv30_routines 3325',errmax,errmaxrel)
4503	endif !if (iso_eau.gt.0) then
4504	do ixt=1,niso
4505	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3328')
4506	enddo
4507	if ((iso_HDO.gt.0).and. &
4508	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
4509	if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
4510	& +delt*fxt(iso_HDO,il,i)) &
4511	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3396a, dtr mels') &
4512	& .eq.1) then
4513	write(,) 'il,k,i=',il,k,i
4514	write(,) 'rr,delt,fr=',rr(il,i),delt,fr(il,i)
4515	write(,) 'frnew=',0.01gravdpinvment(il, k, i)(qent(il,k,i)-awat-rr(il,i))
4516	write(,) 'frold=',fr(il,i)-0.01gravdpinvment(il, k, i)(qent(il,k,i)-awat-rr(il,i))
4517	write(,) 'deltaDfrnew=',deltaD((xtent(iso_HDO,il,k,i)-xtawat(iso_HDO)-xt(iso_HDO,il,i)) &
4518	/(qent(il,k,i)-awat-rr(il,i)))
4519	write(,) 'deltaDfrold=',deltaD((fxt(iso_HDO,il,i) &
4520	-0.01gravdpinvment(il, k, i)(xtent(iso_HDO,il,k,i)-xtawat(iso_HDO)-xt(iso_HDO,il,i))) &
4521	/(fr(il,i)-0.01gravdpinvment(il, k, i)(qent(il,k,i)-awat-rr(il,i))))
4522	write(,) 'q+=',rr(il,i)+delt*fr(il,i)
4523	write(,) 'qent,awat=',qent(il,k,i),awat
4524	write(,) 'elij,clw,ep=',elij(il,k,i),clw(il,i),ep(il,i)
4525	write(,) 'deltaDfr=',deltaD(fxt(iso_hdo,il,i)/fr(il,i))
4526	write(,) 'deltaDrr=',deltaD(xt(iso_hdo,il,i)/rr(il,i))
4527	write(,) 'deltaDqent=',deltaD(xtent(iso_hdo,il,k,i) &
4528	& /qent(il,k,i))
4529	write(,) 'deltaDqent-awat=',deltaD((xtent(iso_hdo,il,k,i)-xtawat(iso_HDO)) &
4530	& /(qent(il,k,i)-awat))
4531	write(,) 'deltaDawat=',deltaD(xtawat(iso_hdo)/awat)
4532	write(,) 'deltaDclw=',deltaD(xtclw(iso_hdo,il,i)/clw(il,i))
4533	! stop
4534	endif
4535	if (iso_O18.gt.0) then
4536	call iso_verif_O18_aberrant( &
4537	& (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
4538	& /(rr(il,i)+delt*fr(il,i)), &
4539	& (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
4540	& /(rr(il,i)+delt*fr(il,i)), &
4541	& 'cv30_yield 3396aO18, dtr mels')
4542	endif !if (iso_O18.gt.0) then
4543	endif !if (iso_HDO.gt.0) then
4544	#ifdef ISOTRAC
4545	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3784')
4546	do ixt=1,ntraciso
4547	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
4548	enddo
4549	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3905',1e-5) &
4550	& .eq.1) then
4551	write(,) 'il,i=',il,i
4552	endif
4553	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 3905',1e-5)
4554	#endif
4555	#endif
4556	#endif
4557	ELSE ! cvflag_grav
4558	fr(il, i) = fr(il, i) + 0.1dpinvment(il, k, i)*(qent(il,k,i)- &
4559	awat-rr(il,i))
4560	fu(il, i) = fu(il, i) + 0.01gravdpinvment(il, k, i)(uent(il,k &
4561	,i)-u(il,i))
4562	fv(il, i) = fv(il, i) + 0.1dpinvment(il, k, i)*(vent(il,k,i)-v( &
4563	il,i))
4564
4565	#ifdef ISO
4566	do ixt = 1, ntraciso
4567	fxt(ixt,il,i)=fxt(ixt,il,i) &
4568	& +0.1dpinvment(il,k,i) &
4569	& *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
4570	enddo
4571
4572	#ifdef DIAGISO
4573	fq_detrainement(il,i)=fq_detrainement(il,i) &
4574	& +0.1dpinvment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
4575	f_detrainement(il,i)=f_detrainement(il,i) &
4576	& +0.1dpinvment(il,k,i)
4577	q_detrainement(il,i)=q_detrainement(il,i) &
4578	& +0.1dpinvment(il,k,i)*qent(il,k,i)
4579	do ixt = 1, niso
4580	fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
4581	& +0.1dpinvment(il,k,i) &
4582	& *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
4583	xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
4584	& +0.1dpinvment(il,k,i)*xtent(ixt,il,k,i)
4585	enddo
4586	#endif
4587
4588	! cam verif
4589	#ifdef ISOVERIF
4590	if (iso_eau.gt.0) then
4591	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
4592	& fr(il,i),'cv30_routines 3350',errmax,errmaxrel)
4593	endif !if (iso_eau.gt.0) then
4594	do ixt=1,niso
4595	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3353')
4596	enddo
4597	if ((iso_HDO.gt.0).and. &
4598	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
4599	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
4600	& +delt*fxt(iso_HDO,il,i)) &
4601	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3396b, dtr mels')
4602	endif !if (iso_HDO.gt.0) then
4603	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
4604	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
4605	call iso_verif_O18_aberrant( &
4606	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
4607	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
4608	& 'cv30_yield 3396b,O18, dtr mels')
4609	endif !if (iso_HDO.gt.0) then
4610	#ifdef ISOTRAC
4611	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3828')
4612	do ixt=1,ntraciso
4613	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
4614	enddo
4615	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3949',1e-5) &
4616	& .eq.1) then
4617	write(,) 'il,i=',il,i
4618	endif
4619	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 3949',1e-5)
4620	#endif
4621	#endif
4622	! end cam verif
4623	#endif
4624
4625	END IF ! cvflag_grav
4626
4627	! (saturated updrafts resulting from mixing) ! cld
4628	qcond(il, i) = qcond(il, i) + (elij(il,k,i)-awat) ! cld
4629	nqcond(il, i) = nqcond(il, i) + 1. ! cld
4630	END IF ! i
4631	END DO
4632	END DO
4633
4634	! do j=1,ntra
4635	! do k=1,i-1
4636	! do il=1,ncum
4637	! if (i.le.inb(il)) then
4638	! dpinv=1.0/(ph(il,i)-ph(il,i+1))
4639	! cpinv=1.0/cpn(il,i)
4640	! if (cvflag_grav) then
4641	! ftra(il,i,j)=ftra(il,i,j)+0.01gravdpinv*ment(il,k,i)
4642	! : *(traent(il,k,i,j)-tra(il,i,j))
4643	! else
4644	! ftra(il,i,j)=ftra(il,i,j)+0.1dpinvment(il,k,i)
4645	! : *(traent(il,k,i,j)-tra(il,i,j))
4646	! endif
4647	! endif
4648	! enddo
4649	! enddo
4650	! enddo
4651
4652	DO k = i, nl + 1
4653	DO il = 1, ncum
4654	IF (i<=inb(il) .AND. k<=inb(il)) THEN
4655	dpinv = 1.0/(ph(il,i)-ph(il,i+1))
4656	cpinv = 1.0/cpn(il, i)
4657
4658	IF (cvflag_grav) THEN
4659	fr(il, i) = fr(il, i) + 0.01gravdpinvment(il, k, i)(qent(il,k &
4660	,i)-rr(il,i))
4661	fu(il, i) = fu(il, i) + 0.01gravdpinvment(il, k, i)(uent(il,k &
4662	,i)-u(il,i))
4663	fv(il, i) = fv(il, i) + 0.01gravdpinvment(il, k, i)(vent(il,k &
4664	,i)-v(il,i))
4665	#ifdef ISO
4666	do ixt = 1, ntraciso
4667	fxt(ixt,il,i)=fxt(ixt,il,i) &
4668	& +0.01gravdpinvment(il,k,i)(xtent(ixt,il,k,i)-xt(ixt,il,i))
4669	enddo
4670
4671	#ifdef DIAGISO
4672	fq_detrainement(il,i)=fq_detrainement(il,i) &
4673	& +0.01gravdpinvment(il,k,i)(qent(il,k,i)-rr(il,i))
4674	f_detrainement(il,i)=f_detrainement(il,i) &
4675	& +0.01gravdpinv*ment(il,k,i)
4676	q_detrainement(il,i)=q_detrainement(il,i) &
4677	& +0.01gravdpinvment(il,k,i)qent(il,k,i)
4678	do ixt = 1, niso
4679	fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
4680	& +0.01gravdpinvment(il,k,i)(xtent(ixt,il,k,i)-xt(ixt,il,i))
4681	xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
4682	& +0.01gravdpinvment(il,k,i)xtent(ixt,il,k,i)
4683	enddo
4684	#endif
4685
4686	! cam verif
4687	#ifdef ISOVERIF
4688	if ((il.eq.1636).and.(i.eq.9)) then
4689	write(,) 'cv30 4785: on ajoute le dtr ici:'
4690	write(,) 'M=',0.01gravdpinv*ment(il, k, i)
4691	write(,) 'q,qe=',rr(il,i),qent(il,k,i)
4692	bx=0.01gravdpinvment(il,k,i)(qent(il,k,i)-rr(il,i))
4693	do ixt=1,niso
4694	xtbx(ixt)=0.01gravdpinvment(il,k,i)(xtent(ixt,il,k,i)-xt(ixt,il,i))
4695	enddo
4696	endif
4697	do ixt=1,niso
4698	call iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 4351')
4699	enddo
4700	#endif
4701	#ifdef ISOVERIF
4702	if (iso_eau.gt.0) then
4703	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
4704	& fr(il,i),'cv30_routines 3408',errmax,errmaxrel)
4705	endif !if (iso_eau.gt.0) then
4706	do ixt=1,niso
4707	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3411')
4708	enddo
4709	if (1.eq.0) then
4710	if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
4711	if (iso_verif_aberrant_enc_nostop( &
4712	& fxt(iso_HDO,il,i)/fr(il,i), &
4713	& 'cv30_yield 3572, dtr mels').eq.1) then
4714	write(,) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
4715	write(,) 'fr(il,i)=',fr(il,i)
4716	! if (fr(il,i).gt.ridicule*1e5) then
4717	! stop
4718	! endif
4719	endif
4720	endif !if (iso_HDO.gt.0) then
4721	endif !if (1.eq.0) then
4722	if ((iso_HDO.gt.0).and. &
4723	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
4724	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
4725	& +delt*fxt(iso_HDO,il,i)) &
4726	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3605, dtr mels')
4727	if (iso_O18.gt.0) then
4728	call iso_verif_O18_aberrant( &
4729	& (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
4730	& /(rr(il,i)+delt*fr(il,i)), &
4731	& (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
4732	& /(rr(il,i)+delt*fr(il,i)), &
4733	& 'cv30_yield 3605O18, dtr mels')
4734	if ((il.eq.1636).and.(i.eq.9)) then
4735	call iso_verif_O18_aberrant( &
4736	& (xt(iso_HDO,il,i)+delt*(fxt(iso_HDO,il,i)-xtbx(iso_HDO))) &
4737	& /(rr(il,i)+delt*(fr(il,i)-bx)), &
4738	& (xt(iso_O18,il,i)+delt*(fxt(iso_O18,il,i)-xtbx(iso_O18))) &
4739	& /(rr(il,i)+delt*(fr(il,i)-bx)), &
4740	& 'cv30_yield 3605O18_nobx, dtr mels')
4741	endif !if ((il.eq.1636).and.(i.eq.9)) then
4742	endif !if (iso_O18.gt.0) then
4743	endif !if (iso_HDO.gt.0) then
4744	#ifdef ISOTRAC
4745	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3921')
4746	do ixt=1,ntraciso
4747	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
4748	enddo
4749	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4036',1e-5) &
4750	& .eq.1) then
4751	write(,) 'il,i=',il,i
4752	endif
4753	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 4036',1e-5)
4754	#endif
4755	#endif
4756	! end cam verif
4757	#endif
4758	ELSE ! cvflag_grav
4759	fr(il, i) = fr(il, i) + 0.1dpinvment(il, k, i)*(qent(il,k,i)-rr &
4760	(il,i))
4761	fu(il, i) = fu(il, i) + 0.1dpinvment(il, k, i)*(uent(il,k,i)-u( &
4762	il,i))
4763	fv(il, i) = fv(il, i) + 0.1dpinvment(il, k, i)*(vent(il,k,i)-v( &
4764	il,i))
4765
4766	#ifdef ISO
4767	do ixt = 1, ntraciso
4768	fxt(ixt,il,i)=fxt(ixt,il,i) &
4769	& +0.1dpinvment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
4770	enddo
4771
4772	#ifdef DIAGISO
4773	fq_detrainement(il,i)=fq_detrainement(il,i) &
4774	& +0.1dpinvment(il,k,i)*(qent(il,k,i)-rr(il,i))
4775	f_detrainement(il,i)=f_detrainement(il,i) &
4776	& +0.1dpinvment(il,k,i)
4777	q_detrainement(il,i)=q_detrainement(il,i) &
4778	& +0.1dpinvment(il,k,i)*qent(il,k,i)
4779	do ixt = 1, niso
4780	fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
4781	& +0.1dpinvment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
4782	xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
4783	& +0.1dpinvment(il,k,i)*xtent(ixt,il,k,i)
4784	enddo
4785	#endif
4786
4787	! cam verif
4788	#ifdef ISOVERIF
4789	if ((il.eq.1636).and.(i.eq.9)) then
4790	write(,) 'cv30 4785b: on ajoute le dtr ici:'
4791	write(,) 'M=',0.1dpinvment(il, k, i)
4792	write(,) 'q,qe=',rr(il,i),qent(il,k,i)
4793	endif
4794	if (iso_eau.gt.0) then
4795	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
4796	& fr(il,i),'cv30_routines 3433',errmax,errmaxrel)
4797	endif !if (iso_eau.gt.0) then
4798	do ixt=1,niso
4799	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3436')
4800	enddo
4801	if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
4802	if (iso_verif_aberrant_enc_nostop( &
4803	& fxt(iso_HDO,il,i)/fr(il,i), &
4804	& 'cv30_yield 3597').eq.1) then
4805	write(,) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
4806	stop
4807	endif
4808	endif !if (iso_HDO.gt.0) then
4809	if ((iso_HDO.gt.0).and. &
4810	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
4811	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
4812	& +delt*fxt(iso_HDO,il,i)) &
4813	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3605b, dtr mels')
4814	endif !if (iso_HDO.gt.0) then
4815	#ifdef ISOTRAC
4816	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3972')
4817	do ixt=1,ntraciso
4818	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
4819	enddo
4820	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4091',1e-5) &
4821	& .eq.1) then
4822	write(,) 'il,i=',il,i
4823	endif
4824	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 4091',1e-5)
4825	#endif
4826	#endif
4827	! end cam verif
4828	#endif
4829	END IF ! cvflag_grav
4830	END IF ! i and k
4831	END DO
4832	END DO
4833
4834	! do j=1,ntra
4835	! do k=i,nl+1
4836	! do il=1,ncum
4837	! if (i.le.inb(il) .and. k.le.inb(il)) then
4838	! dpinv=1.0/(ph(il,i)-ph(il,i+1))
4839	! cpinv=1.0/cpn(il,i)
4840	! if (cvflag_grav) then
4841	! ftra(il,i,j)=ftra(il,i,j)+0.01gravdpinv*ment(il,k,i)
4842	! : *(traent(il,k,i,j)-tra(il,i,j))
4843	! else
4844	! ftra(il,i,j)=ftra(il,i,j)+0.1dpinvment(il,k,i)
4845	! : *(traent(il,k,i,j)-tra(il,i,j))
4846	! endif
4847	! endif ! i and k
4848	! enddo
4849	! enddo
4850	! enddo
4851
4852	DO il = 1, ncum
4853	IF (i<=inb(il)) THEN
4854	dpinv = 1.0/(ph(il,i)-ph(il,i+1))
4855	cpinv = 1.0/cpn(il, i)
4856
4857	IF (cvflag_grav) THEN
4858	! sb: on ne fait pas encore la correction permettant de mieux
4859	! conserver l'eau:
4860	fr(il, i) = fr(il, i) + 0.5sigd(evap(il,i)+evap(il,i+1)) + &
4861	0.01grav(mp(il,i+1)(rp(il,i+1)-rr(il,i))-mp(il,i)(rp(il, &
4862	i)-rr(il,i-1)))*dpinv
4863
4864	fu(il, i) = fu(il, i) + 0.01grav(mp(il,i+1)*(up(il,i+1)-u(il, &
4865	i))-mp(il,i)(up(il,i)-u(il,i-1)))dpinv
4866	fv(il, i) = fv(il, i) + 0.01grav(mp(il,i+1)*(vp(il,i+1)-v(il, &
4867	i))-mp(il,i)(vp(il,i)-v(il,i-1)))dpinv
4868	#ifdef ISO
4869	do ixt = 1, niso
4870	fxt(ixt,il,i)=fxt(ixt,il,i) &
4871	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
4872	& +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
4873	& -mp(il,i) &
4874	& (xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
4875	enddo
4876
4877	#ifdef DIAGISO
4878	fq_evapprecip(il,i)=fq_evapprecip(il,i) &
4879	& +0.5sigd(evap(il,i)+evap(il,i+1))
4880	fq_ddft(il,i)=fq_ddft(il,i) &
4881	& +0.01grav(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i) &
4882	& (rp(il,i)-rr(il,i-1)))dpinv
4883	do ixt = 1, niso
4884	fxt_evapprecip(ixt,il,i)=fxt_evapprecip(ixt,il,i) &
4885	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
4886	fxt_ddft(ixt,il,i)=fxt_ddft(ixt,il,i) &
4887	& +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
4888	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
4889	enddo
4890	#endif
4891
4892	#ifdef ISOVERIF
4893	do ixt=1,niso
4894	call iso_verif_noNaN(xt(ixt,il,i),'cv30_yield 4514')
4895	call iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 4515')
4896	enddo
4897	if ((iso_HDO.gt.0).and. &
4898	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
4899	if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
4900	& +delt*fxt(iso_HDO,il,i)) &
4901	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 4175') &
4902	& .eq.1) then
4903	write(,) 'il,i=',il,i
4904	if (rr(il,i).ne.0.0) then
4905	write(,) 'il,i,rr,deltaD=',il,i,rr(il,i),deltaD &
4906	& (xt(iso_HDO,il,i)/rr(il,i))
4907	endif
4908	if (fr(il,i).ne.0.0) then
4909	write(,) 'fr,fxt,deltaD=',fr(il,i),fxt(iso_HDO,il,i), &
4910	& deltaD(fxt(iso_HDO,il,i)/fr(il,i))
4911	endif
4912	#ifdef DIAGISO
4913	if (fq_ddft(il,i).ne.0.0) then
4914	write(,) 'fq_ddft,deltaD=',fq_ddft(il,i),deltaD( &
4915	& fxt_ddft(iso_HDO,il,i)/fq_ddft(il,i))
4916	endif
4917	if (fq_evapprecip(il,i).ne.0.0) then
4918	write(,) 'fq_evapprecip,deltaD=',fq_evapprecip(il,i),deltaD( &
4919	& fxt_evapprecip(iso_HDO,il,i)/fq_evapprecip(il,i))
4920	endif
4921	#endif
4922	write(,) 'sigd,evap(il,i),evap(il,i+1)=', &
4923	& sigd,evap(il,i),evap(il,i+1)
4924	write(,) 'xtevap(iso_HDO,il,i),xtevap(iso_HDO,il,i+1)=', &
4925	& xtevap(iso_HDO,il,i),xtevap(iso_HDO,il,i+1)
4926	write(,) 'grav,mp(il,i+1),mp(il,i),dpinv=', &
4927	& grav,mp(il,i+1),mp(il,i),dpinv
4928	write(,) 'rp(il,i+1),rr(il,i),rp(il,i),rr(il,i-1)=', &
4929	& rp(il,i+1),rr(il,i),rp(il,i),rr(il,i-1)
4930	write(,) 'xtp(il,i+1),xt(il,i),xtp(il,i),xt(il,i-1)=', &
4931	& xtp(iso_HDO,il,i+1),xt(iso_HDO,il,i), &
4932	& xtp(iso_HDO,il,i),xt(iso_HDO,il,i-1)
4933	stop
4934	endif
4935	endif !if (iso_HDO.gt.0) then
4936	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
4937	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
4938	call iso_verif_O18_aberrant( &
4939	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
4940	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
4941	& 'cv30_yield 5029,O18, evap')
4942	if ((il.eq.1636).and.(i.eq.9)) then
4943	write(,) 'cv30_yield 5057: ici, on verifie deltaD_nobx'
4944	write(,) 'il,i=',il,i
4945	write(,) 'fr(il,i),bx,fr(il,i)-bx=',fr(il,i),bx,fr(il,i)-bx
4946	write(,) 'q,q+=',rr(il,i),rr(il,i)+delt*(fr(il,i)-bx)
4947	write(,) 'deltaD,deltaD+=',deltaD(xt(iso_HDO,il,inb(il))/rr(il,inb(il))), &
4948	& deltaD( (xt(iso_HDO,il,i)+delt(fxt(iso_HDO,il,i)-xtbx(iso_HDO)))/(rr(il,i)+delt(fr(il,i)-bx)))
4949	write(,) 'deltaO18,deltaO18+=',deltaO(xt(iso_O18,il,inb(il))/rr(il,inb(il))), &
4950	& deltaO( (xt(iso_O18,il,i)+delt(fxt(iso_O18,il,i)-xtbx(iso_O18)))/(rr(il,i)+delt(fr(il,i)-bx)))
4951	call iso_verif_O18_aberrant( &
4952	& (xt(iso_HDO,il,i)+delt*(fxt(iso_HDO,il,i)-xtbx(iso_HDO))) &
4953	& /(rr(il,i)+delt*(fr(il,i)-bx)), &
4954	& (xt(iso_O18,il,i)+delt*(fxt(iso_O18,il,i)-xtbx(iso_O18))) &
4955	& /(rr(il,i)+delt*(fr(il,i)-bx)), &
4956	& 'cv30_yield 5029_nobx,O18, evap, no bx')
4957	endif !if ((il.eq.1636).and.(i.eq.9)) then
4958	endif !if (iso_HDO.gt.0) then
4959	#endif
4960
4961	#ifdef ISOTRAC
4962	if ((option_traceurs.ne.6).and.(option_traceurs.ne.19)) then
4963
4964	! facile: on fait comme l'eau
4965	do ixt = 1+niso,ntraciso
4966	fxt(ixt,il,i)=fxt(ixt,il,i) &
4967	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
4968	& +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
4969	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
4970	enddo !do ixt = 1+niso,ntraciso
4971
4972	else ! taggage des ddfts:
4973	! la formule pour fq_ddft suppose que le ddft est en RP. Ce n'est pas le
4974	! cas pour le water tagging puisqu'il y a conversion des molecules
4975	! blances entrainees en molecule rouges.
4976	! Il faut donc prendre en compte ce taux de conversion quand
4977	! entrainement d'env vers ddft
4978	! conversion(iiso)=0.01gravdpinv
4979	! : (mp(il,i)-mp(il,i+1))xt(ixt_poubelle,il,i)
4980	! fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+conversion(iiso)
4981	! fxt(ixt_poubelle,il,i)=fxt(ixt_poubelle,il,i)
4982	! : -conversion(iiso)
4983
4984	! Pb: quand on discretise, dqp/dt n'est pas verifee numeriquement.
4985	! on se retrouve donc avec des d Ye/dt differents de 0 meme si ye=0 ( on
4986	! note X les molecules poubelles et Y les molecules ddfts).
4987
4988	! Solution alternative: Dans le cas entrainant, Ye ne varie que par
4989	! ascendance compensatoire des ddfts et par perte de Ye vers le ddft. On
4990	! calcule donc ce terme directement avec schema amont:
4991
4992	! ajout deja de l'evap
4993	do ixt = 1+niso,ntraciso
4994	fxt(ixt,il,i)=fxt(ixt,il,i) &
4995	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
4996	enddo !do ixt = 1+niso,ntraciso
4997
4998	! ajout du terme des ddfts sensi stricto
4999	! write(,) 'tmp cv3_yield 4165: i,il=',i,il
5000	!
5001	if (option_traceurs.eq.6) then
5002	do iiso = 1, niso
5003
5004	ixt_ddft=itZonIso(izone_ddft,iiso)
5005	if (mp(il,i).gt.mp(il,i+1)) then
5006	fxtYe(iiso)=0.01gravdpinv*mp(il,i) &
5007	& *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
5008	else !if (mp(il,i).gt.mp(il,i+1)) then
5009	fxtYe(iiso)=0.01gravdpinv*(mp(il,i) &
5010	& xt(ixt_ddft,il,i-1)-mp(il,i+1)xt(ixt_ddft,il,i) &
5011	& +(mp(il,i+1)-mp(il,i))*xtp(ixt_ddft,il,i))
5012	endif !if (mp(il,i).gt.mp(il,i+1)) then
5013	fxtqe(iiso)=0.01gravdpinv* &
5014	& (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
5015	& -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
5016
5017	ixt_poubelle=itZonIso(izone_poubelle,iiso)
5018	fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+fxtYe(iiso)
5019	fxt(ixt_poubelle,il,i)=fxt(ixt_poubelle,il,i) &
5020	& +fxtqe(iiso)-fxtYe(iiso)
5021	enddo !do iiso = 1, niso
5022
5023	else !if (option_traceurs.eq.6) then
5024
5025
5026	if (mp(il,i).gt.mp(il,i+1)) then
5027	! cas entrainant: faire attention
5028
5029	do iiso = 1, niso
5030	fxtqe(iiso)=0.01gravdpinv* &
5031	& (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
5032	& -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
5033
5034	ixt_ddft=itZonIso(izone_ddft,iiso)
5035	fxtYe(iiso)=0.01gravdpinv*mp(il,i) &
5036	& *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
5037	fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+fxtYe(iiso)
5038
5039	ixt_revap=itZonIso(izone_revap,iiso)
5040	fxt_revap(iiso)=0.01gravdpinv(mp(il,i+1) &
5041	& (xtp(ixt_revap,il,i+1)-xt(ixt_revap,il,i)) &
5042	& -mp(il,i)*(xtp(ixt_revap,il,i)-xt(ixt_revap,il,i-1)))
5043	fxt(ixt_revap,il,i)=fxt(ixt_revap,il,i) &
5044	& +fxt_revap(iiso)
5045
5046	fxtXe(iiso)=fxtqe(iiso)-fxtYe(iiso)-fxt_revap(iiso)
5047	Xe(iiso)=xt(iiso,il,i) &
5048	& -xt(ixt_ddft,il,i)-xt(ixt_revap,il,i)
5049	if (Xe(iiso).gt.ridicule) then
5050	do izone=1,nzone
5051	if ((izone.ne.izone_revap).and. &
5052	& (izone.ne.izone_ddft)) then
5053	ixt=itZonIso(izone,iiso)
5054	fxt(ixt,il,i)=fxt(ixt,il,i) &
5055	& +xt(ixt,il,i)/Xe(iiso)*fxtXe(iiso)
5056	endif !if ((izone.ne.izone_revap).and.
5057	enddo !do izone=1,nzone
5058	#ifdef ISOVERIF
5059	! write(,) 'iiso=',iiso
5060	! write(,) 'fxtqe=',fxtqe(iiso)
5061	! write(,) 'fxtYe=',fxtYe(iiso)
5062	! write(,) 'fxt_revap=',fxt_revap(iiso)
5063	! write(,) 'fxtXe=',fxtXe(iiso)
5064	! write(,) 'Xe=',Xe(iiso)
5065	! write(,) 'xt=',xt(:,il,i)
5066	call iso_verif_traceur_justmass(fxt(1,il,i), &
5067	& 'cv30_routine 4646')
5068	#endif
5069	else !if (abs(dXe).gt.ridicule) then
5070	! dans ce cas, fxtXe doit etre faible
5071
5072	#ifdef ISOVERIF
5073	if (delt*fxtXe(iiso).gt.ridicule) then
5074	write(,) 'cv30_routines 6563: delt*fxtXe(iiso)=', &
5075	& delt*fxtXe(iiso)
5076	stop
5077	endif
5078	#endif
5079	do izone=1,nzone
5080	if ((izone.ne.izone_revap).and. &
5081	& (izone.ne.izone_ddft)) then
5082	ixt=itZonIso(izone,iiso)
5083	if (izone.eq.izone_poubelle) then
5084	fxt(ixt,il,i)=fxt(ixt,il,i)+fxtXe(iiso)
5085	else !if (izone.eq.izone_poubelle) then
5086	! pas de tendance pour ce tag la
5087	endif !if (izone.eq.izone_poubelle) then
5088	endif !if ((izone.ne.izone_revap).and.
5089	enddo !do izone=1,nzone
5090	#ifdef ISOVERIF
5091	call iso_verif_traceur_justmass(fxt(1,il,i), &
5092	& 'cv30_routine 4671')
5093	#endif
5094
5095	endif !if (abs(dXe).gt.ridicule) then
5096
5097	enddo !do iiso = 1, niso
5098
5099	else !if (mp(il,i).gt.mp(il,i+1)) then
5100	! cas detrainant: pas de problemes
5101	do ixt=1+niso,ntraciso
5102	fxt(ixt,il,i)=fxt(ixt,il,i) &
5103	& +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
5104	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
5105	enddo !do ixt=1+niso,ntraciso
5106	#ifdef ISOVERIF
5107	call iso_verif_traceur_justmass(fxt(1,il,i), &
5108	& 'cv30_routine 4685')
5109	#endif
5110	endif !if (mp(il,i).gt.mp(il,i+1)) then
5111
5112	endif !if (option_traceurs.eq.6) then
5113
5114	! write(,) 'deltconversion=',deltconversion(iso_eau)
5115	! write(,) 'deltfxtYe=',deltfxtYe(iso_eau)
5116	! write(,) 'deltfxtqe=',deltfxtqe(iso_eau)
5117
5118	endif ! if ((option_traceurs.ne.6).and.(option_traceurs.ne.19)) then
5119	#endif
5120
5121	! cam verif
5122	#ifdef ISOVERIF
5123	do ixt=1,niso
5124	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3496')
5125	enddo
5126	#endif
5127	#ifdef ISOVERIF
5128	if (iso_eau.gt.0) then
5129	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
5130	& fr(il,i),'cv30_routines 3493',errmax,errmaxrel)
5131	endif !if (iso_eau.gt.0) then
5132	if (1.eq.0) then
5133	if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
5134	if (iso_verif_aberrant_enc_nostop( &
5135	& fxt(iso_HDO,il,i)/fr(il,i), &
5136	& 'cv30_yield 3662').eq.1) then
5137	write(,) 'il,i,icb(il),inb(il)=',il,i,icb(il),inb(il)
5138	write(,) 'fr(il,i),delt=',fr(il,i),delt
5139	#ifdef DIAGISO
5140	if (fq_ddft(il,i).ne.0.0) then
5141	write(,) 'fq_ddft,deltaD=',fq_ddft(il,i),deltaD( &
5142	& fxt_ddft(iso_HDO,il,i)/fq_ddft(il,i))
5143	endif !if (fq_ddft(il,i).ne.0.0) then
5144	if (fq_evapprecip(il,i).ne.0.0) then
5145	write(,) 'fq_evapprecip,deltaD=',fq_evapprecip(il,i), &
5146	& deltaD(fxt_evapprecip(iso_HDO,il,i) &
5147	& /fq_evapprecip(il,i))
5148	endif !if (fq_evapprecip(il,i).ne.0.0) then
5149	#endif
5150	endif !if (iso_verif_aberrant_enc_nostop(
5151	endif !if (iso_HDO.gt.0) then
5152	endif !if (1.eq.0) then
5153	if ((iso_HDO.gt.0).and. &
5154	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
5155	if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
5156	& +delt*fxt(iso_HDO,il,i)) &
5157	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3757, ddfts') &
5158	& .eq.1) then
5159	write(,) 'i,il,q,deltaD=',i,il,rr(il,i),deltaD( &
5160	& xt(iso_HDO,il,i)/rr(il,i))
5161	write(,) 'i,il,fr,deltaD=',i,il,fr(il,i),deltaD( &
5162	& fxt(iso_HDO,il,i)/fr(il,i))
5163	stop
5164	endif ! if (iso_verif_aberrant_enc_nostop
5165	endif !if (iso_HDO.gt.0) then
5166
5167	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
5168	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
5169	call iso_verif_O18_aberrant( &
5170	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
5171	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
5172	& 'cv30_yield 5250,O18, ddfts')
5173	endif !if (iso_HDO.gt.0) then
5174
5175	#ifdef ISOTRAC
5176	! write(,) 'tmp cv3_yield 4224: i,il=',i,il
5177	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 4107')
5178	do ixt=1,ntraciso
5179	xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
5180	enddo
5181	if (iso_verif_tracpos_choix_nostop(xtnew, &
5182	& 'cv30_yield 4221',1e-5).eq.1) then
5183	write(,) 'deltfxt(,il,i)=',deltfxt(1:ntraciso:2,il,i)
5184	write(,) 'deltfxt(,il,i)=',deltfxt(:,il,i)
5185	write(,) 'xt(,il,i)=',xt(:,il,i)
5186	write(,) 'delt,sigd,grav,dpinv=',delt,sigd,grav,dpinv
5187	write(,) 'xtevap(,il,i)=',xtevap(:,il,i)
5188	write(,) 'xtevap(,il,i+1)=',xtevap(:,il,i+1)
5189	write(,) 'mp(il,i+1),mp(il,i)=',mp(il,i+1),mp(il,i)
5190	write(,) 'xtp(,il,i)=',xtp(:,il,i)
5191	write(,) 'xtp(,il,i+1)=',xtp(:,il,i+1)
5192	write(,) 'xt(,il,i)=',xt(:,il,i)
5193	write(,) 'xt(,il,i-1)=',xt(:,il,i-1)
5194	! rappel: fxt(ixt,il,i)=fxt(ixt,il,i)
5195	! 0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
5196	! : +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i))
5197	! : -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
5198	! stop
5199	endif
5200	#endif
5201	#endif
5202	#endif
5203	ELSE ! cvflag_grav
5204	fr(il, i) = fr(il, i) + 0.5sigd(evap(il,i)+evap(il,i+1)) + &
5205	0.1(mp(il,i+1)(rp(il,i+1)-rr(il,i))-mp(il,i)*(rp(il,i)-rr(il, &
5206	i-1)))*dpinv
5207	fu(il, i) = fu(il, i) + 0.1(mp(il,i+1)(up(il,i+1)-u(il, &
5208	i))-mp(il,i)(up(il,i)-u(il,i-1)))dpinv
5209	fv(il, i) = fv(il, i) + 0.1(mp(il,i+1)(vp(il,i+1)-v(il, &
5210	i))-mp(il,i)(vp(il,i)-v(il,i-1)))dpinv
5211	#ifdef ISO
5212	do ixt = 1, ntraciso
5213	fxt(ixt,il,i)=fxt(ixt,il,i) &
5214	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
5215	& +0.1(mp(il,i+1)(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
5216	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
5217	enddo ! ixt=1,niso
5218
5219	#ifdef ISOTRAC
5220	if (option_traceurs.ne.6) then
5221
5222	! facile: on fait comme l'eau
5223	do ixt = 1+niso,ntraciso
5224	fxt(ixt,il,i)=fxt(ixt,il,i) &
5225	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
5226	& +0.01grav(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
5227	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
5228	enddo !do ixt = 1+niso,ntraciso
5229
5230	else !if (option_traceurs.ne.6) then
5231
5232	! taggage des ddfts: voir blabla + haut
5233	do ixt = 1+niso,ntraciso
5234	fxt(ixt,il,i)=fxt(ixt,il,i) &
5235	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
5236	enddo !do ixt = 1+niso,ntraciso
5237	! write(,) 'tmp cv3_yield 4165: i,il=',i,il
5238	! ixt_poubelle=itZonIso(izone_poubelle,iso_eau)
5239	! ixt_ddft=itZonIso(izone_ddft,iso_eau)
5240	! write(,) 'delt*fxt(ixt_poubelle,il,i)=',
5241	! : delt*fxt(ixt_poubelle,il,i)
5242	! write(,) 'deltfxt(ixt_ddft,il,i)=',deltfxt(ixt_ddft,il,i)
5243	! write(,) 'xt(iso_eau,il,i)=',xt(iso_eau,il,i)
5244	do iiso = 1, niso
5245	ixt_poubelle=itZonIso(izone_poubelle,iiso)
5246	ixt_ddft=itZonIso(izone_ddft,iiso)
5247	if (mp(il,i).gt.mp(il,i+1)) then
5248	fxtYe(iiso)=0.01gravdpinv*mp(il,i) &
5249	& *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
5250	else !if (mp(il,i).gt.mp(il,i+1)) then
5251	fxtYe(iiso)=0.01gravdpinv*(mp(il,i) &
5252	& xt(ixt_ddft,il,i-1)-mp(il,i+1)xt(ixt_ddft,il,i) &
5253	& +(mp(il,i+1)-mp(il,i))*xtp(ixt_ddft,il,i))
5254	endif !if (mp(il,i).gt.mp(il,i+1)) then
5255	fxtqe(iiso)=0.01gravdpinv* &
5256	& (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
5257	& -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
5258	fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+fxtYe(iiso)
5259	fxt(ixt_poubelle,il,i)=fxt(ixt_poubelle,il,i) &
5260	& +fxtqe(iiso)-fxtYe(iiso)
5261	enddo !do iiso = 1, niso
5262	! write(,) 'deltconversion=',deltconversion(iso_eau)
5263	! write(,) 'deltfxtYe=',deltfxtYe(iso_eau)
5264	! write(,) 'deltfxtqe=',deltfxtqe(iso_eau)
5265	endif !if (option_traceurs.eq.6) then
5266	#endif
5267
5268	#ifdef DIAGISO
5269	fq_evapprecip(il,i)=fq_evapprecip(il,i) &
5270	& +0.5sigd(evap(il,i)+evap(il,i+1))
5271	fq_ddft(il,i)=fq_ddft(il,i) &
5272	& +0.1(mp(il,i+1)(rp(il,i+1)-rr(il,i))-mp(il,i) &
5273	& (rp(il,i)-rr(il,i-1)))dpinv
5274	do ixt = 1, niso
5275	fxt_evapprecip(ixt,il,i)=fxt_evapprecip(ixt,il,i) &
5276	& +0.5sigd(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
5277	fxt_ddft(ixt,il,i)=fxt_ddft(ixt,il,i) &
5278	& +0.1(mp(il,i+1)(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
5279	& -mp(il,i)(xtp(ixt,il,i)-xt(ixt,il,i-1)))dpinv
5280	enddo ! ixt=1,niso
5281	#endif
5282
5283	! cam verif
5284
5285	#ifdef ISOVERIF
5286	do ixt=1,niso
5287	call iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 5083')
5288	enddo
5289	#endif
5290	#ifdef ISOVERIF
5291	if (iso_eau.gt.0) then
5292	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
5293	& fr(il,i),'cv30_routines 3522',errmax,errmaxrel)
5294	endif !if (iso_eau.gt.0) then
5295	if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
5296	if (iso_verif_aberrant_enc_nostop( &
5297	& fxt(iso_HDO,il,i)/fr(il,i), &
5298	& 'cv30_yield 3690').eq.1) then
5299	write(,) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
5300	stop
5301	endif
5302	endif !if (iso_HDO.gt.0) then
5303	if ((iso_HDO.gt.0).and. &
5304	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
5305	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
5306	& +delt*fxt(iso_HDO,il,i)) &
5307	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3757b, ddfts')
5308	endif !if (iso_HDO.gt.0) then
5309	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
5310	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
5311	call iso_verif_O18_aberrant( &
5312	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
5313	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
5314	& 'cv30_yield 3757b,O18, ddfts')
5315	endif !if (iso_HDO.gt.0) then
5316	#ifdef ISOTRAC
5317	call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 4172')
5318	do ixt=1,ntraciso
5319	xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
5320	enddo
5321	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4295',1e-5) &
5322	& .eq.1) then
5323	write(,) 'il,i=',il,i
5324	endif
5325	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 4295',1e-5)
5326	#endif
5327	#endif
5328	! end cam verif
5329	#endif
5330
5331	END IF ! cvflag_grav
5332
5333	END IF ! i
5334	END DO
5335
5336	! sb: interface with the cloud parameterization: ! cld
5337
5338	DO k = i + 1, nl
5339	DO il = 1, ncum
5340	IF (k<=inb(il) .AND. i<=inb(il)) THEN ! cld
5341	! (saturated downdrafts resulting from mixing) ! cld
5342	qcond(il, i) = qcond(il, i) + elij(il, k, i) ! cld
5343	nqcond(il, i) = nqcond(il, i) + 1. ! cld
5344	END IF ! cld
5345	END DO ! cld
5346	END DO ! cld
5347
5348	! (particular case: no detraining level is found) ! cld
5349	DO il = 1, ncum ! cld
5350	IF (i<=inb(il) .AND. nent(il,i)==0) THEN ! cld
5351	qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i) ! cld
5352	nqcond(il, i) = nqcond(il, i) + 1. ! cld
5353	END IF ! cld
5354	END DO ! cld
5355
5356	DO il = 1, ncum ! cld
5357	IF (i<=inb(il) .AND. nqcond(il,i)/=0.) THEN ! cld
5358	qcond(il, i) = qcond(il, i)/nqcond(il, i) ! cld
5359	END IF ! cld
5360	END DO
5361
5362	! do j=1,ntra
5363	! do il=1,ncum
5364	! if (i.le.inb(il)) then
5365	! dpinv=1.0/(ph(il,i)-ph(il,i+1))
5366	! cpinv=1.0/cpn(il,i)
5367
5368	! if (cvflag_grav) then
5369	! ftra(il,i,j)=ftra(il,i,j)+0.01gravdpinv
5370	! : (mp(il,i+1)(trap(il,i+1,j)-tra(il,i,j))
5371	! : -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
5372	! else
5373	! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
5374	! : (mp(il,i+1)(trap(il,i+1,j)-tra(il,i,j))
5375	! : -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
5376	! endif
5377	! endif ! i
5378	! enddo
5379	! enddo
5380
5381	500 END DO
5382
5383
5384	! * move the detrainment at level inb down to level inb-1 *
5385	! * in such a way as to preserve the vertically *
5386	! * integrated enthalpy and water tendencies *
5387
5388	DO il = 1, ncum
5389
5390	! attention, on corrige un probleme C Risi
5391	IF (cvflag_grav) then
5392
5393	ax = 0.01gravment(il, inb(il), inb(il))*(hp(il,inb(il))-h(il,inb(il))+t(il, &
5394	inb(il))(cpv-cpd)(rr(il,inb(il))-qent(il,inb(il), &
5395	inb(il))))/(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
5396	ft(il, inb(il)) = ft(il, inb(il)) - ax
5397	ft(il, inb(il)-1) = ft(il, inb(il)-1) + axcpn(il, inb(il))(ph(il,inb(il &
5398	))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il, &
5399	inb(il))))
5400
5401	bx = 0.01gravment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))-rr(il,inb( &
5402	il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
5403	fr(il, inb(il)) = fr(il, inb(il)) - bx
5404	fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+ &
5405	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
5406
5407	cx = 0.01gravment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u(il,inb(il &
5408	)))/(ph(il,inb(il))-ph(il,inb(il)+1))
5409	fu(il, inb(il)) = fu(il, inb(il)) - cx
5410	fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+ &
5411	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
5412
5413	dx = 0.01gravment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v(il,inb(il &
5414	)))/(ph(il,inb(il))-ph(il,inb(il)+1))
5415	fv(il, inb(il)) = fv(il, inb(il)) - dx
5416	fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+ &
5417	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
5418
5419
5420	#ifdef ISO
5421	do ixt = 1, ntraciso
5422	xtbx(ixt)=0.01gravment(il,inb(il),inb(il)) &
5423	& *(xtent(ixt,il,inb(il),inb(il)) &
5424	& -xt(ixt,il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
5425	fxt(ixt,il,inb(il))=fxt(ixt,il,inb(il))-xtbx(ixt)
5426	fxt(ixt,il,inb(il)-1)=fxt(ixt,il,inb(il)-1) &
5427	& +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
5428	& /(ph(il,inb(il)-1)-ph(il,inb(il)))
5429	enddo !do ixt = 1, niso
5430	#endif
5431
5432	else !IF (cvflag_grav)
5433	ax = 0.1ment(il, inb(il), inb(il))(hp(il,inb(il))-h(il,inb(il))+t(il, &
5434	inb(il))(cpv-cpd)(rr(il,inb(il))-qent(il,inb(il), &
5435	inb(il))))/(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
5436	ft(il, inb(il)) = ft(il, inb(il)) - ax
5437	ft(il, inb(il)-1) = ft(il, inb(il)-1) + axcpn(il, inb(il))(ph(il,inb(il &
5438	))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il, &
5439	inb(il))))
5440
5441	bx = 0.1ment(il, inb(il), inb(il))(qent(il,inb(il),inb(il))-rr(il,inb( &
5442	il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
5443	fr(il, inb(il)) = fr(il, inb(il)) - bx
5444	fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+ &
5445	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
5446
5447	cx = 0.1ment(il, inb(il), inb(il))(uent(il,inb(il),inb(il))-u(il,inb(il &
5448	)))/(ph(il,inb(il))-ph(il,inb(il)+1))
5449	fu(il, inb(il)) = fu(il, inb(il)) - cx
5450	fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+ &
5451	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
5452
5453	dx = 0.1ment(il, inb(il), inb(il))(vent(il,inb(il),inb(il))-v(il,inb(il &
5454	)))/(ph(il,inb(il))-ph(il,inb(il)+1))
5455	fv(il, inb(il)) = fv(il, inb(il)) - dx
5456	fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+ &
5457	1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
5458
5459
5460
5461	#ifdef ISO
5462	do ixt = 1, ntraciso
5463	xtbx(ixt)=0.1*ment(il,inb(il),inb(il)) &
5464	& *(xtent(ixt,il,inb(il),inb(il)) &
5465	& -xt(ixt,il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
5466	fxt(ixt,il,inb(il))=fxt(ixt,il,inb(il))-xtbx(ixt)
5467	fxt(ixt,il,inb(il)-1)=fxt(ixt,il,inb(il)-1) &
5468	& +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
5469	& /(ph(il,inb(il)-1)-ph(il,inb(il)))
5470	enddo !do ixt = 1, niso
5471	#endif
5472
5473	endif !IF (cvflag_grav)
5474
5475
5476	#ifdef ISO
5477	#ifdef DIAGISO
5478	fq_detrainement(il,inb(il))=fq_detrainement(il,inb(il))-bx
5479	fq_detrainement(il,inb(il)-1)=fq_detrainement(il,inb(il)-1) &
5480	& +bx*(ph(il,inb(il))-ph(il,inb(il)+1)) &
5481	& /(ph(il,inb(il)-1)-ph(il,inb(il)))
5482	do ixt = 1, niso
5483	fxt_detrainement(ixt,il,inb(il))= &
5484	& fxt_detrainement(ixt,il,inb(il))-xtbx(ixt)
5485	fxt_detrainement(ixt,il,inb(il)-1)= &
5486	& fxt_detrainement(ixt,il,inb(il)-1) &
5487	& +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
5488	& /(ph(il,inb(il)-1)-ph(il,inb(il)))
5489	enddo
5490	#endif
5491	! cam verif
5492	#ifdef ISOVERIF
5493	do ixt=1,niso
5494	call iso_verif_noNaN(fxt(ixt,il,inb(il)),'cv30_yield 5083')
5495	enddo
5496	if (iso_eau.gt.0) then
5497	call iso_verif_egalite_choix(fxt(iso_eau,il,inb(il)), &
5498	& fr(il,inb(il)),'cv30_routines 3638',errmax,errmaxrel)
5499	call iso_verif_egalite_choix(fxt(iso_eau,il,inb(il)-1), &
5500	& fr(il,inb(il)-1),'cv30_routines 3640',errmax,errmaxrel)
5501	endif !if (iso_eau.gt.0) then
5502	if ((iso_HDO.gt.0).and. &
5503	& (rr(il,inb(il))+delt*fr(il,inb(il)).gt.ridicule)) then
5504	call iso_verif_aberrant_encadre( &
5505	& (xt(iso_HDO,il,inb(il))+delt*fxt(iso_HDO,il,inb(il))) &
5506	& /(rr(il,inb(il))+delt*fr(il,inb(il))), &
5507	& 'cv30_yield 3921, en inb')
5508	if (iso_O18.gt.0) then
5509	if (iso_verif_O18_aberrant_nostop( &
5510	& (xt(iso_HDO,il,inb(il))+delt*fxt(iso_HDO,il,inb(il))) &
5511	& /(rr(il,inb(il))+delt*fr(il,inb(il))), &
5512	& (xt(iso_O18,il,inb(il))+delt*fxt(iso_O18,il,inb(il))) &
5513	& /(rr(il,inb(il))+delt*fr(il,inb(il))), &
5514	& 'cv30_yield 3921O18, en inb').eq.1) then
5515	write(,) 'il,inb(il)=',il,inb(il)
5516	k_tmp=0.1*ment(il,inb(il),inb(il))/(ph(il,inb(il))-ph(il,inb(il)+1))
5517	write(,) 'fr,frprec=',fr(il,inb(il)),fr(il,inb(il))+bx
5518	write(,) 'M,dt,k_tmpdt=',k_tmp,delt,k_tmpdelt
5519	write(,) 'q,qe=',rr(il,inb(il)),qent(il,inb(il),inb(il))
5520	write(,) 'r=',k_tmpdeltqent(il,inb(il),inb(il))/rr(il,inb(il))
5521	write(,) 'deltaDR,Re=',deltaD(xt(iso_HDO,il,inb(il))/rr(il,inb(il))), &
5522	& deltaD(xtent(iso_HDO,il,inb(il),inb(il))/qent(il,inb(il),inb(il)))
5523	write(,) 'deltaO18R,Re=',deltaO(xt(iso_O18,il,inb(il))/rr(il,inb(il))), &
5524	& deltaO(xtent(iso_O18,il,inb(il),inb(il))/qent(il,inb(il),inb(il)))
5525	stop
5526	endif !if (iso_verif_O18_aberrant_nostop
5527	endif !if (iso_O18.gt.0) then
5528	endif !if (iso_HDO.gt.0) then
5529	if ((iso_HDO.gt.0).and. &
5530	& (rr(il,inb(il)-1)+delt*fr(il,inb(il)-1).gt.ridicule)) then
5531	call iso_verif_aberrant_encadre( &
5532	& (xt(iso_HDO,il,inb(il)-1) &
5533	& +delt*fxt(iso_HDO,il,inb(il)-1)) &
5534	& /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
5535	& 'cv30_yield 3921b, en inb-1')
5536	if (iso_O18.gt.0) then
5537	call iso_verif_O18_aberrant( &
5538	& (xt(iso_HDO,il,inb(il)-1)+delt*fxt(iso_HDO,il,inb(il)-1)) &
5539	& /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
5540	& (xt(iso_O18,il,inb(il)-1)+delt*fxt(iso_O18,il,inb(il)-1)) &
5541	& /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
5542	& 'cv30_yield 3921cO18, en inb-1')
5543	endif
5544	endif !if (iso_HDO.gt.0) then
5545	#ifdef ISOTRAC
5546	call iso_verif_traceur_justmass(fxt(1,il,inb(il)-1), &
5547	& 'cv30_routine 4364')
5548	call iso_verif_traceur_justmass(fxt(1,il,inb(il)), &
5549	& 'cv30_routine 4364b')
5550	do ixt=1,ntraciso
5551	xtnew(ixt)=xt(ixt,il,inb(il))+delt*fxt(ixt,il,inb(il))
5552	enddo
5553	if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4492',1e-5) &
5554	& .eq.1) then
5555	write(,) 'il,i=',il,i
5556	endif
5557	! call iso_verif_tracpos_choix(xtnew,'cv30_yield 4492',1e-5)
5558	#endif
5559	#endif
5560	! end cam verif
5561	#endif
5562
5563	END DO
5564
5565	! do j=1,ntra
5566	! do il=1,ncum
5567	! ex=0.1*ment(il,inb(il),inb(il))
5568	! : *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
5569	! : /(ph(il,inb(il))-ph(il,inb(il)+1))
5570	! ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
5571	! ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
5572	! : +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
5573	! : /(ph(il,inb(il)-1)-ph(il,inb(il)))
5574	! enddo
5575	! enddo
5576
5577
5578	! * homoginize tendencies below cloud base *
5579
5580
5581	DO il = 1, ncum
5582	asum(il) = 0.0
5583	bsum(il) = 0.0
5584	csum(il) = 0.0
5585	dsum(il) = 0.0
5586	#ifdef ISO
5587	frsum(il)=0.0
5588	do ixt=1,ntraciso
5589	fxtsum(ixt,il)=0.0
5590	bxtsum(ixt,il)=0.0
5591	enddo
5592	#endif
5593	END DO
5594
5595	DO i = 1, nl
5596	DO il = 1, ncum
5597	IF (i<=(icb(il)-1)) THEN
5598	asum(il) = asum(il) + ft(il, i)*(ph(il,i)-ph(il,i+1))
5599	bsum(il) = bsum(il) + fr(il, i)(lv(il,i)+(cl-cpd)(t(il,i)-t(il, &
5600	1)))*(ph(il,i)-ph(il,i+1))
5601	csum(il) = csum(il) + (lv(il,i)+(cl-cpd)*(t(il,i)-t(il, &
5602	1)))*(ph(il,i)-ph(il,i+1))
5603	dsum(il) = dsum(il) + t(il, i)*(ph(il,i)-ph(il,i+1))/th(il, i)
5604	#ifdef ISO
5605
5606	frsum(il)=frsum(il)+fr(il,i)
5607	do ixt=1,ntraciso
5608	fxtsum(ixt,il)=fxtsum(ixt,il)+fxt(ixt,il,i)
5609	bxtsum(ixt,il)=bxtsum(ixt,il)+fxt(ixt,il,i) &
5610	& (lv(il,i)+(cl-cpd)(t(il,i)-t(il,1))) &
5611	& *(ph(il,i)-ph(il,i+1))
5612	enddo
5613	#endif
5614	END IF
5615	END DO
5616	END DO
5617
5618	! !!! do 700 i=1,icb(il)-1
5619	DO i = 1, nl
5620	DO il = 1, ncum
5621	IF (i<=(icb(il)-1)) THEN
5622	ft(il, i) = asum(il)t(il, i)/(th(il,i)dsum(il))
5623	fr(il, i) = bsum(il)/csum(il)
5624	#ifdef ISO
5625	if (abs(csum(il)).gt.0.0) then
5626	do ixt=1,ntraciso
5627	fxt(ixt,il,i)=bxtsum(ixt,il)/csum(il)
5628	enddo
5629	else !if (frsum(il).gt.ridicule) then
5630	if (abs(frsum(il)).gt.0.0) then
5631	do ixt=1,ntraciso
5632	fxt(ixt,il,i)=fr(il,i)*fxtsum(ixt,il)/frsum(il)
5633	enddo
5634	else !if (abs(frsum(il)).gt.0.0) then
5635	if (abs(fr(il,i))*delt.gt.ridicule) then
5636	write(,) 'cv30_yield 4048: fr(il,i)=',fr(il,i)
5637	stop
5638	else !if (abs(fr(il,i))*delt.gt.ridicule) then
5639	do ixt=1,ntraciso
5640	fxt(ixt,il,i)=0.0
5641	enddo
5642	if (iso_eau.gt.0) then
5643	fxt(iso_eau,il,i)=1.0
5644	endif
5645	endif !if (abs(fr(il,i))*delt.gt.ridicule) then
5646	endif !if (abs(frsum(il)).gt.0.0) then
5647	endif !if (frsum(il).gt.0) then
5648	#endif
5649	END IF
5650	END DO
5651	END DO
5652
5653
5654	#ifdef ISO
5655	#ifdef ISOVERIF
5656	do i=1,nl
5657	do il=1,ncum
5658	do ixt=1,ntraciso
5659	call iso_verif_noNAN(fxt(ixt,il,i),'cv30_yield 3826')
5660	enddo
5661	enddo
5662	enddo
5663	#endif
5664	#ifdef ISOVERIF
5665	do i=1,nl
5666	! write(,) 'cv30_routines temp 3967: i=',i
5667	do il=1,ncum
5668	! write(,) 'cv30_routines 3969: il=',il
5669	! write(,) 'cv30_routines temp 3967: il,i,inb(il),ncum=',
5670	! : il,i,inb(il),ncum
5671	! write(,) 'cv30_routines 3974'
5672	if (iso_eau.gt.0) then
5673	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
5674	& fr(il,i),'cv30_yield 3830',errmax,errmaxrel)
5675	endif !if (iso_eau.gt.0) then
5676	! write(,) 'cv30_routines 3979'
5677	if ((iso_HDO.gt.0).and. &
5678	& (delt*fr(il,i).gt.ridicule)) then
5679	if (iso_verif_aberrant_enc_nostop( &
5680	& fxt(iso_HDO,il,i)/fr(il,i), &
5681	& 'cv30_yield 3834').eq.1) then
5682	if (fr(il,i).gt.ridicule*1e5) then
5683	write(,) 'il,i,icb(il)=',il,i,icb(il)
5684	write(,) 'frsum(il)=',frsum(il)
5685	write(,) 'fr(il,i)=',fr(il,i)
5686	write(,) 'csum(il)=',csum(il)
5687	write(,) &
5688	& 'deltaD(bxtsum(iso_HDO,il)/csum(il))=', &
5689	& deltaD(bxtsum(iso_HDO,il)/csum(il))
5690	! stop
5691	endif
5692	! write(,) 'cv30_routines 3986: temporaire'
5693	endif !if (iso_verif_aberrant_enc_nostop
5694	endif !if (iso_HDO.gt.0) then
5695	if ((iso_HDO.gt.0).and. &
5696	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
5697	if (iso_verif_aberrant_enc_nostop( &
5698	& (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
5699	& /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3921c, dans la CL') &
5700	& .eq.1) then
5701	write(,) 'il,i,icb(il)=',il,i,icb(il)
5702	write(,) 'frsum(il)=',frsum(il)
5703	write(,) 'fr(il,i)=',fr(il,i)
5704	stop
5705	endif
5706	endif !if (iso_HDO.gt.0) then
5707
5708	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
5709	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
5710	call iso_verif_O18_aberrant( &
5711	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
5712	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
5713	& 'cv30_yield 3921d, dans la CL')
5714	endif !if (iso_HDO.gt.0) then
5715	#ifdef ISOTRAC
5716	call iso_verif_traceur_justmass(fxt(1,il,i), &
5717	& 'cv30_routine 4523')
5718	#endif
5719	! write(,) 'cv30_routines 3994'
5720	enddo !do il=1,ncum
5721	! write(,) 'cv30_routine 3990: fin des il pour i=',i
5722	enddo !do i=1,nl
5723	! write(,) 'cv30_routine 3990: fin des verifs sur homogen'
5724	#endif
5725
5726	#ifdef ISOVERIF
5727	! verif finale des tendances:
5728	do i=1,nl
5729	do il=1,ncum
5730	if (iso_eau.gt.0) then
5731	call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
5732	& fr(il,i),'cv30_yield 3830',errmax,errmaxrel)
5733	endif !if (iso_eau.gt.0) then
5734	if ((iso_HDO.gt.0).and. &
5735	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
5736	call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
5737	& +delt*fxt(iso_HDO,il,i)) &
5738	& /(rr(il,i)+delt*fr(il,i)), &
5739	& 'cv30_yield 5710a, final')
5740	endif !if (iso_HDO.gt.0) then
5741	if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
5742	& (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
5743	call iso_verif_O18_aberrant( &
5744	& (xt(iso_HDO,il,i)+deltfxt(iso_HDO,il,i))/(rr(il,i)+deltfr(il,i)), &
5745	& (xt(iso_O18,il,i)+deltfxt(iso_O18,il,i))/(rr(il,i)+deltfr(il,i)), &
5746	& 'cv30_yield 5710b, final')
5747	endif !if (iso_HDO.gt.0) then
5748	enddo !do il=1,ncum
5749	enddo !do i=1,nl
5750	#endif
5751
5752	#endif
5753
5754
5755	! * reset counter and return *
5756
5757	DO il = 1, ncum
5758	sig(il, nd) = 2.0
5759	END DO
5760
5761
5762	DO i = 1, nd
5763	DO il = 1, ncum
5764	upwd(il, i) = 0.0
5765	dnwd(il, i) = 0.0
5766	END DO
5767	END DO
5768
5769	DO i = 1, nl
5770	DO il = 1, ncum
5771	dnwd0(il, i) = -mp(il, i)
5772	END DO
5773	END DO
5774	DO i = nl + 1, nd
5775	DO il = 1, ncum
5776	dnwd0(il, i) = 0.
5777	END DO
5778	END DO
5779
5780
5781	DO i = 1, nl
5782	DO il = 1, ncum
5783	IF (i>=icb(il) .AND. i<=inb(il)) THEN
5784	upwd(il, i) = 0.0
5785	dnwd(il, i) = 0.0
5786	END IF
5787	END DO
5788	END DO
5789
5790	DO i = 1, nl
5791	DO k = 1, nl
5792	DO il = 1, ncum
5793	up1(il, k, i) = 0.0
5794	dn1(il, k, i) = 0.0
5795	END DO
5796	END DO
5797	END DO
5798
5799	DO i = 1, nl
5800	DO k = i, nl
5801	DO n = 1, i - 1
5802	DO il = 1, ncum
5803	IF (i>=icb(il) .AND. i<=inb(il) .AND. k<=inb(il)) THEN
5804	up1(il, k, i) = up1(il, k, i) + ment(il, n, k)
5805	dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n)
5806	END IF
5807	END DO
5808	END DO
5809	END DO
5810	END DO
5811
5812	DO i = 2, nl
5813	DO k = i, nl
5814	DO il = 1, ncum
5815	! test if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il))
5816	! then
5817	IF (i<=inb(il) .AND. k<=inb(il)) THEN
5818	upwd(il, i) = upwd(il, i) + m(il, k) + up1(il, k, i)
5819	dnwd(il, i) = dnwd(il, i) + dn1(il, k, i)
5820	END IF
5821	END DO
5822	END DO
5823	END DO
5824
5825
5826	! !!! DO il=1,ncum
5827	! !!! do i=icb(il),inb(il)
5828	! !!!
5829	! !!! upwd(il,i)=0.0
5830	! !!! dnwd(il,i)=0.0
5831	! !!! do k=i,inb(il)
5832	! !!! up1=0.0
5833	! !!! dn1=0.0
5834	! !!! do n=1,i-1
5835	! !!! up1=up1+ment(il,n,k)
5836	! !!! dn1=dn1-ment(il,k,n)
5837	! !!! enddo
5838	! !!! upwd(il,i)=upwd(il,i)+m(il,k)+up1
5839	! !!! dnwd(il,i)=dnwd(il,i)+dn1
5840	! !!! enddo
5841	! !!! enddo
5842	! !!!
5843	! !!! ENDDO
5844
5845	! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5846	! determination de la variation de flux ascendant entre
5847	! deux niveau non dilue mike
5848	! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5849
5850	DO i = 1, nl
5851	DO il = 1, ncum
5852	mike(il, i) = m(il, i)
5853	END DO
5854	END DO
5855
5856	DO i = nl + 1, nd
5857	DO il = 1, ncum
5858	mike(il, i) = 0.
5859	END DO
5860	END DO
5861
5862	DO i = 1, nd
5863	DO il = 1, ncum
5864	ma(il, i) = 0
5865	END DO
5866	END DO
5867
5868	DO i = 1, nl
5869	DO j = i, nl
5870	DO il = 1, ncum
5871	ma(il, i) = ma(il, i) + m(il, j)
5872	END DO
5873	END DO
5874	END DO
5875
5876	DO i = nl + 1, nd
5877	DO il = 1, ncum
5878	ma(il, i) = 0.
5879	END DO
5880	END DO
5881
5882	DO i = 1, nl
5883	DO il = 1, ncum
5884	IF (i<=(icb(il)-1)) THEN
5885	ma(il, i) = 0
5886	END IF
5887	END DO
5888	END DO
5889
5890	! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5891	! icb represente de niveau ou se trouve la
5892	! base du nuage , et inb le top du nuage
5893	! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5894
5895	DO i = 1, nd
5896	DO il = 1, ncum
5897	mke(il, i) = upwd(il, i) + dnwd(il, i)
5898	END DO
5899	END DO
5900
5901	DO i = 1, nd
5902	DO il = 1, ncum
5903	rdcp = (rrd(1.-rr(il,i))-rr(il,i)rrv)/(cpd*(1.-rr(il, &
5904	i))+rr(il,i)*cpv)
5905	tls(il, i) = t(il, i)(1000.0/p(il,i))*rdcp
5906	tps(il, i) = tp(il, i)
5907	END DO
5908	END DO
5909
5910
5911	! * diagnose the in-cloud mixing ratio * ! cld
5912	! * of condensed water * ! cld
5913	! ! cld
5914
5915	DO i = 1, nd ! cld
5916	DO il = 1, ncum ! cld
5917	mac(il, i) = 0.0 ! cld
5918	wa(il, i) = 0.0 ! cld
5919	siga(il, i) = 0.0 ! cld
5920	sax(il, i) = 0.0 ! cld
5921	END DO ! cld
5922	END DO ! cld
5923
5924	DO i = minorig, nl ! cld
5925	DO k = i + 1, nl + 1 ! cld
5926	DO il = 1, ncum ! cld
5927	IF (i<=inb(il) .AND. k<=(inb(il)+1)) THEN ! cld
5928	mac(il, i) = mac(il, i) + m(il, k) ! cld
5929	END IF ! cld
5930	END DO ! cld
5931	END DO ! cld
5932	END DO ! cld
5933
5934	DO i = 1, nl ! cld
5935	DO j = 1, i ! cld
5936	DO il = 1, ncum ! cld
5937	IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
5938	.AND. j>=icb(il)) THEN ! cld
5939	sax(il, i) = sax(il, i) + rrd*(tvp(il,j)-tv(il,j)) & ! cld
5940	*(ph(il,j)-ph(il,j+1))/p(il, j) ! cld
5941	END IF ! cld
5942	END DO ! cld
5943	END DO ! cld
5944	END DO ! cld
5945
5946	DO i = 1, nl ! cld
5947	DO il = 1, ncum ! cld
5948	IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
5949	.AND. sax(il,i)>0.0) THEN ! cld
5950	wa(il, i) = sqrt(2.*sax(il,i)) ! cld
5951	END IF ! cld
5952	END DO ! cld
5953	END DO ! cld
5954
5955	DO i = 1, nl ! cld
5956	DO il = 1, ncum ! cld
5957	IF (wa(il,i)>0.0) & ! cld
5958	siga(il, i) = mac(il, i)/wa(il, i) & ! cld
5959	rrdtvp(il, i)/p(il, i)/100./delta ! cld
5960	siga(il, i) = min(siga(il,i), 1.0) ! cld
5961	! IM cf. FH
5962	IF (iflag_clw==0) THEN
5963	qcondc(il, i) = siga(il, i)clw(il, i)(1.-ep(il,i)) & ! cld
5964	+(1.-siga(il,i))*qcond(il, i) ! cld
5965	ELSE IF (iflag_clw==1) THEN
5966	qcondc(il, i) = qcond(il, i) ! cld
5967	END IF
5968
5969	END DO ! cld
5970	END DO ! cld
5971
5972	RETURN
5973	END SUBROUTINE cv30_yield
5974
5975	! !RomP >>>
5976	SUBROUTINE cv30_tracer(nloc, len, ncum, nd, na, ment, sij, da, phi, phi2, &
5977	d1a, dam, ep, vprecip, elij, clw, epmlmmm, eplamm, icb, inb)
5978	IMPLICIT NONE
5979
5980	include "cv30param.h"
5981
5982	! inputs:
5983	INTEGER ncum, nd, na, nloc, len
5984	REAL ment(nloc, na, na), sij(nloc, na, na)
5985	REAL clw(nloc, nd), elij(nloc, na, na)
5986	REAL ep(nloc, na)
5987	INTEGER icb(nloc), inb(nloc)
5988	REAL vprecip(nloc, nd+1)
5989	! ouputs:
5990	REAL da(nloc, na), phi(nloc, na, na)
5991	REAL phi2(nloc, na, na)
5992	REAL d1a(nloc, na), dam(nloc, na)
5993	REAL epmlmmm(nloc, na, na), eplamm(nloc, na)
5994	! variables pour tracer dans precip de l'AA et des mel
5995	! local variables:
5996	INTEGER i, j, k, nam1
5997	REAL epm(nloc, na, na)
5998
5999	nam1=na-1 ! Introduced because ep is not defined for j=na
6000	! variables d'Emanuel : du second indice au troisieme
6001	! ---> tab(i,k,j) -> de l origine k a l arrivee j
6002	! ment, sij, elij
6003	! variables personnelles : du troisieme au second indice
6004	! ---> tab(i,j,k) -> de k a j
6005	! phi, phi2
6006
6007	! initialisations
6008	DO j = 1, na
6009	DO i = 1, ncum
6010	da(i, j) = 0.
6011	d1a(i, j) = 0.
6012	dam(i, j) = 0.
6013	eplamm(i, j) = 0.
6014	END DO
6015	END DO
6016	DO k = 1, na
6017	DO j = 1, na
6018	DO i = 1, ncum
6019	epm(i, j, k) = 0.
6020	epmlmmm(i, j, k) = 0.
6021	phi(i, j, k) = 0.
6022	phi2(i, j, k) = 0.
6023	END DO
6024	END DO
6025	END DO
6026
6027	! fraction deau condensee dans les melanges convertie en precip : epm
6028	! et eau condensee precipitee dans masse d'air sature : l_m*dM_m/dzdz.dzdz
6029	DO j = 1, nam1
6030	DO k = 1, j - 1
6031	DO i = 1, ncum
6032	IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
6033	! !jyg epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
6034	epm(i, j, k) = 1. - (1.-ep(i,j))*clw(i, j)/max(elij(i,k,j), 1.E-16)
6035	! !
6036	epm(i, j, k) = max(epm(i,j,k), 0.0)
6037	END IF
6038	END DO
6039	END DO
6040	END DO
6041
6042	DO j = 1, nam1
6043	DO k = 1, nam1
6044	DO i = 1, ncum
6045	IF (k>=icb(i) .AND. k<=inb(i)) THEN
6046	eplamm(i, j) = eplamm(i, j) + ep(i, j)clw(i, j)ment(i, j, k)*(1.- &
6047	sij(i,j,k))
6048	END IF
6049	END DO
6050	END DO
6051	END DO
6052
6053	DO j = 1, nam1
6054	DO k = 1, j - 1
6055	DO i = 1, ncum
6056	IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
6057	epmlmmm(i, j, k) = epm(i, j, k)elij(i, k, j)ment(i, k, j)
6058	END IF
6059	END DO
6060	END DO
6061	END DO
6062
6063	! matrices pour calculer la tendance des concentrations dans cvltr.F90
6064	DO j = 1, nam1
6065	DO k = 1, nam1
6066	DO i = 1, ncum
6067	da(i, j) = da(i, j) + (1.-sij(i,k,j))*ment(i, k, j)
6068	phi(i, j, k) = sij(i, k, j)*ment(i, k, j)
6069	d1a(i, j) = d1a(i, j) + ment(i, k, j)ep(i, k)(1.-sij(i,k,j))
6070	END DO
6071	END DO
6072	END DO
6073
6074	DO j = 1, nam1
6075	DO k = 1, j - 1
6076	DO i = 1, ncum
6077	dam(i, j) = dam(i, j) + ment(i, k, j)epm(i, j, k)(1.-ep(i,k))*(1.- &
6078	sij(i,k,j))
6079	phi2(i, j, k) = phi(i, j, k)*epm(i, j, k)
6080	END DO
6081	END DO
6082	END DO
6083
6084	RETURN
6085	END SUBROUTINE cv30_tracer
6086	! RomP <<<
6087
6088	SUBROUTINE cv30_uncompress(nloc, len, ncum, nd, ntra, idcum, iflag, precip, &
6089	vprecip, evap, ep, sig, w0, ft, fq, fu, fv, ftra, inb, ma, upwd, dnwd, &
6090	dnwd0, qcondc, wd, cape, da, phi, mp, phi2, d1a, dam, sij, elij, clw, &
6091	epmlmmm, eplamm, wdtraina, wdtrainm,epmax_diag, iflag1, precip1, vprecip1, evap1, &
6092	ep1, sig1, w01, ft1, fq1, fu1, fv1, ftra1, inb1, ma1, upwd1, dnwd1, &
6093	dnwd01, qcondc1, wd1, cape1, da1, phi1, mp1, phi21, d1a1, dam1, sij1, &
6094	elij1, clw1, epmlmmm1, eplamm1, wdtraina1, wdtrainm1,epmax_diag1 & ! epmax_cape
6095	#ifdef ISO
6096	& ,xtprecip,fxt,xtVPrecip,xtevap,xtclw,xtwdtraina &
6097	& ,xtprecip1,fxt1,xtVPrecip1,xtevap1,xtclw1,xtwdtraina1 &
6098	#ifdef DIAGISO
6099	& , water,xtwater,qp,xtp &
6100	& , fq_detrainement,fq_ddft,fq_fluxmasse,fq_evapprecip &
6101	& , fxt_detrainement,fxt_ddft,fxt_fluxmasse, fxt_evapprecip &
6102	& , f_detrainement,q_detrainement,xt_detrainement &
6103	& , water1,xtwater1,qp1,xtp1 &
6104	& , fq_detrainement1,fq_ddft1,fq_fluxmasse1,fq_evapprecip1 &
6105	& , fxt_detrainement1,fxt_ddft1,fxt_fluxmasse1, fxt_evapprecip1 &
6106	& , f_detrainement1,q_detrainement1,xt_detrainement1 &
6107	#endif
6108	#endif
6109	& )
6110
6111	#ifdef ISO
6112	use infotrac_phy, ONLY: ntraciso=>ntiso
6113	#ifdef ISOVERIF
6114	use isotopes_verif_mod, ONLY: Tmin_verif,iso_verif_aberrant, &
6115	iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
6116	iso_verif_egalite_nostop,iso_verif_aberrant_nostop,deltaD,iso_verif_noNaN_nostop, &
6117	iso_verif_positif,iso_verif_egalite_vect2D
6118	#endif
6119	#endif
6120	IMPLICIT NONE
6121
6122	include "cv30param.h"
6123
6124	! inputs:
6125	INTEGER len, ncum, nd, ntra, nloc
6126	INTEGER idcum(nloc)
6127	INTEGER iflag(nloc)
6128	INTEGER inb(nloc)
6129	REAL precip(nloc)
6130	REAL vprecip(nloc, nd+1), evap(nloc, nd)
6131	REAL ep(nloc, nd)
6132	REAL sig(nloc, nd), w0(nloc, nd)
6133	REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
6134	REAL ftra(nloc, nd, ntra)
6135	REAL ma(nloc, nd)
6136	REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
6137	REAL qcondc(nloc, nd)
6138	REAL wd(nloc), cape(nloc)
6139	REAL da(nloc, nd), phi(nloc, nd, nd), mp(nloc, nd)
6140	REAL epmax_diag(nloc) ! epmax_cape
6141	! RomP >>>
6142	REAL phi2(nloc, nd, nd)
6143	REAL d1a(nloc, nd), dam(nloc, nd)
6144	REAL wdtraina(nloc, nd), wdtrainm(nloc, nd)
6145	REAL sij(nloc, nd, nd)
6146	REAL elij(nloc, nd, nd), clw(nloc, nd)
6147	REAL epmlmmm(nloc, nd, nd), eplamm(nloc, nd)
6148	! RomP <<<
6149	#ifdef ISO
6150	REAL xtprecip(ntraciso,nloc)
6151	REAL xtvprecip(ntraciso,nloc, nd+1), xtevap(ntraciso,nloc, nd)
6152	real fxt(ntraciso,nloc,nd)
6153	real xtclw(ntraciso,nloc,nd)
6154	REAL xtwdtraina(ntraciso,nloc, nd)
6155	#endif
6156
6157	! outputs:
6158	INTEGER iflag1(len)
6159	INTEGER inb1(len)
6160	REAL precip1(len)
6161	REAL vprecip1(len, nd+1), evap1(len, nd) !<<< RomP
6162	REAL ep1(len, nd) !<<< RomP
6163	REAL sig1(len, nd), w01(len, nd)
6164	REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
6165	REAL ftra1(len, nd, ntra)
6166	REAL ma1(len, nd)
6167	REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd)
6168	REAL qcondc1(nloc, nd)
6169	REAL wd1(nloc), cape1(nloc)
6170	REAL da1(nloc, nd), phi1(nloc, nd, nd), mp1(nloc, nd)
6171	REAL epmax_diag1(len) ! epmax_cape
6172	! RomP >>>
6173	REAL phi21(len, nd, nd)
6174	REAL d1a1(len, nd), dam1(len, nd)
6175	REAL wdtraina1(len, nd), wdtrainm1(len, nd)
6176	REAL sij1(len, nd, nd)
6177	REAL elij1(len, nd, nd), clw1(len, nd)
6178	REAL epmlmmm1(len, nd, nd), eplamm1(len, nd)
6179	! RomP <<<
6180	#ifdef ISO
6181	real xtprecip1(ntraciso,len)
6182	real fxt1(ntraciso,len,nd)
6183	real xtVPrecip1(ntraciso,len,nd+1),xtevap1(ntraciso,len, nd)
6184	REAL xtwdtraina1(ntraciso,len, nd)
6185	REAL xtclw1(ntraciso,len, nd)
6186	#endif
6187
6188	! local variables:
6189	INTEGER i, k, j
6190	#ifdef ISO
6191	integer ixt
6192	#endif
6193
6194	#ifdef DIAGISO
6195	real water(nloc,nd)
6196	real xtwater(ntraciso,nloc,nd)
6197	real qp(nloc,nd),xtp(ntraciso,nloc,nd)
6198	real fq_detrainement(nloc,nd)
6199	real f_detrainement(nloc,nd)
6200	real q_detrainement(nloc,nd)
6201	real fq_ddft(nloc,nd)
6202	real fq_fluxmasse(nloc,nd)
6203	real fq_evapprecip(nloc,nd)
6204	real fxt_detrainement(ntraciso,nloc,nd)
6205	real xt_detrainement(ntraciso,nloc,nd)
6206	real fxt_ddft(ntraciso,nloc,nd)
6207	real fxt_fluxmasse(ntraciso,nloc,nd)
6208	real fxt_evapprecip(ntraciso,nloc,nd)
6209
6210	real water1(len,nd)
6211	real xtwater1(ntraciso,len,nd)
6212	real qp1(len,nd),xtp1(ntraciso,len,nd)
6213	real fq_detrainement1(len,nd)
6214	real f_detrainement1(len,nd)
6215	real q_detrainement1(len,nd)
6216	real fq_ddft1(len,nd)
6217	real fq_fluxmasse1(len,nd)
6218	real fq_evapprecip1(len,nd)
6219	real fxt_detrainement1(ntraciso,len,nd)
6220	real xt_detrainement1(ntraciso,len,nd)
6221	real fxt_ddft1(ntraciso,len,nd)
6222	real fxt_fluxmasse1(ntraciso,len,nd)
6223	real fxt_evapprecip1(ntraciso,len,nd)
6224	#endif
6225
6226	#ifdef ISOVERIF
6227	write(,) 'cv30_routines 4293: entree dans cv3_uncompress'
6228	#endif
6229	DO i = 1, ncum
6230	precip1(idcum(i)) = precip(i)
6231	iflag1(idcum(i)) = iflag(i)
6232	wd1(idcum(i)) = wd(i)
6233	inb1(idcum(i)) = inb(i)
6234	cape1(idcum(i)) = cape(i)
6235	epmax_diag1(idcum(i))=epmax_diag(i) ! epmax_cape
6236	#ifdef ISO
6237	do ixt = 1, ntraciso
6238	xtprecip1(ixt,idcum(i))=xtprecip(ixt,i)
6239	enddo
6240	#endif
6241	END DO
6242
6243	DO k = 1, nl
6244	DO i = 1, ncum
6245	vprecip1(idcum(i), k) = vprecip(i, k)
6246	evap1(idcum(i), k) = evap(i, k) !<<< RomP
6247	sig1(idcum(i), k) = sig(i, k)
6248	w01(idcum(i), k) = w0(i, k)
6249	ft1(idcum(i), k) = ft(i, k)
6250	fq1(idcum(i), k) = fq(i, k)
6251	fu1(idcum(i), k) = fu(i, k)
6252	fv1(idcum(i), k) = fv(i, k)
6253	ma1(idcum(i), k) = ma(i, k)
6254	upwd1(idcum(i), k) = upwd(i, k)
6255	dnwd1(idcum(i), k) = dnwd(i, k)
6256	dnwd01(idcum(i), k) = dnwd0(i, k)
6257	qcondc1(idcum(i), k) = qcondc(i, k)
6258	da1(idcum(i), k) = da(i, k)
6259	mp1(idcum(i), k) = mp(i, k)
6260	! RomP >>>
6261	ep1(idcum(i), k) = ep(i, k)
6262	d1a1(idcum(i), k) = d1a(i, k)
6263	dam1(idcum(i), k) = dam(i, k)
6264	clw1(idcum(i), k) = clw(i, k)
6265	eplamm1(idcum(i), k) = eplamm(i, k)
6266	wdtraina1(idcum(i), k) = wdtraina(i, k)
6267	wdtrainm1(idcum(i), k) = wdtrainm(i, k)
6268	! RomP <<<
6269	#ifdef ISO
6270	do ixt = 1, ntraciso
6271	fxt1(ixt,idcum(i),k)=fxt(ixt,i,k)
6272	xtVPrecip1(ixt,idcum(i),k)=xtVPrecip(ixt,i,k)
6273	xtevap1(ixt,idcum(i),k)=xtevap(ixt,i,k)
6274	xtwdtraina1(ixt,idcum(i),k)=xtwdtraina(ixt,i,k)
6275	xtclw1(ixt,idcum(i),k)=xtclw(ixt,i,k)
6276	enddo
6277	#endif
6278	END DO
6279	END DO
6280
6281	DO i = 1, ncum
6282	sig1(idcum(i), nd) = sig(i, nd)
6283	END DO
6284
6285
6286
6287
6288	#ifdef ISO
6289	#ifdef DIAGISO
6290	do k=1,nl
6291	do i=1,ncum
6292	water1(idcum(i),k)=water(i,k)
6293	qp1(idcum(i),k)=qp(i,k)
6294	evap1(idcum(i),k)=evap(i,k)
6295	fq_detrainement1(idcum(i),k)=fq_detrainement(i,k)
6296	f_detrainement1(idcum(i),k)=f_detrainement(i,k)
6297	q_detrainement1(idcum(i),k)=q_detrainement(i,k)
6298	fq_ddft1(idcum(i),k)=fq_ddft(i,k)
6299	fq_evapprecip1(idcum(i),k)=fq_evapprecip(i,k)
6300	fq_fluxmasse1(idcum(i),k)=fq_fluxmasse(i,k)
6301	do ixt = 1, ntraciso
6302	xtwater1(ixt,idcum(i),k)=xtwater(ixt,i,k)
6303	xtp1(ixt,idcum(i),k)=xtp(ixt,i,k)
6304	fxt_detrainement1(ixt,idcum(i),k)=fxt_detrainement(ixt,i,k)
6305	xt_detrainement1(ixt,idcum(i),k)=xt_detrainement(ixt,i,k)
6306	fxt_ddft1(ixt,idcum(i),k)=fxt_ddft(ixt,i,k)
6307	fxt_fluxmasse1(ixt,idcum(i),k)=fxt_fluxmasse(ixt,i,k)
6308	fxt_evapprecip1(ixt,idcum(i),k)=fxt_evapprecip(ixt,i,k)
6309	enddo
6310	enddo
6311	enddo
6312	do i=1,ncum
6313	epmax_diag1(idcum(i))=epmax_diag(i)
6314	enddo
6315
6316	#endif
6317	#endif
6318
6319	! do 2100 j=1,ntra
6320	! do 2110 k=1,nd ! oct3
6321	! do 2120 i=1,ncum
6322	! ftra1(idcum(i),k,j)=ftra(i,k,j)
6323	! 2120 continue
6324	! 2110 continue
6325	! 2100 continue
6326	DO j = 1, nd
6327	DO k = 1, nd
6328	DO i = 1, ncum
6329	sij1(idcum(i), k, j) = sij(i, k, j)
6330	phi1(idcum(i), k, j) = phi(i, k, j)
6331	phi21(idcum(i), k, j) = phi2(i, k, j)
6332	elij1(idcum(i), k, j) = elij(i, k, j)
6333	epmlmmm1(idcum(i), k, j) = epmlmmm(i, k, j)
6334	END DO
6335	END DO
6336	END DO
6337
6338	RETURN
6339	END SUBROUTINE cv30_uncompress
6340
6341	subroutine cv30_epmax_fn_cape(nloc,ncum,nd &
6342	,cape,ep,hp,icb,inb,clw,nk,t,h,lv &
6343	,epmax_diag)
6344	implicit none
6345
6346	! On fait varier epmax en fn de la cape
6347	! Il faut donc recalculer ep, et hp qui a deja ete calcule et
6348	! qui en depend
6349	! Toutes les autres variables fn de ep sont calculees plus bas.
6350
6351	#include "cvthermo.h"
6352	#include "cv30param.h"
6353	#include "conema3.h"
6354
6355	! inputs:
6356	integer ncum, nd, nloc
6357	integer icb(nloc), inb(nloc)
6358	real cape(nloc)
6359	real clw(nloc,nd),lv(nloc,nd),t(nloc,nd),h(nloc,nd)
6360	integer nk(nloc)
6361	! inouts:
6362	real ep(nloc,nd)
6363	real hp(nloc,nd)
6364	! outputs ou local
6365	real epmax_diag(nloc)
6366	! locals
6367	integer i,k
6368	real hp_bak(nloc,nd)
6369	CHARACTER (LEN=20) :: modname='cv30_epmax_fn_cape'
6370	CHARACTER (LEN=80) :: abort_message
6371
6372	! on recalcule ep et hp
6373
6374	if (coef_epmax_cape.gt.1e-12) then
6375	do i=1,ncum
6376	epmax_diag(i)=epmax-coef_epmax_cape*sqrt(cape(i))
6377	do k=1,nl
6378	ep(i,k)=ep(i,k)/epmax*epmax_diag(i)
6379	ep(i,k)=amax1(ep(i,k),0.0)
6380	ep(i,k)=amin1(ep(i,k),epmax_diag(i))
6381	enddo
6382	enddo
6383
6384	! On recalcule hp:
6385	do k=1,nl
6386	do i=1,ncum
6387	hp_bak(i,k)=hp(i,k)
6388	enddo
6389	enddo
6390	do k=1,nlp
6391	do i=1,ncum
6392	hp(i,k)=h(i,k)
6393	enddo
6394	enddo
6395	do k=minorig+1,nl
6396	do i=1,ncum
6397	if((k.ge.icb(i)).and.(k.le.inb(i)))then
6398	hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)t(i,k))ep(i,k)*clw(i,k)
6399	endif
6400	enddo
6401	enddo !do k=minorig+1,n
6402	! write(,) 'cv30_routines 6218: hp(1,20)=',hp(1,20)
6403	do i=1,ncum
6404	do k=1,nl
6405	if (abs(hp_bak(i,k)-hp(i,k)).gt.0.01) then
6406	write(,) 'i,k=',i,k
6407	write(,) 'coef_epmax_cape=',coef_epmax_cape
6408	write(,) 'epmax_diag(i)=',epmax_diag(i)
6409	write(,) 'ep(i,k)=',ep(i,k)
6410	write(,) 'hp(i,k)=',hp(i,k)
6411	write(,) 'hp_bak(i,k)=',hp_bak(i,k)
6412	write(,) 'h(i,k)=',h(i,k)
6413	write(,) 'nk(i)=',nk(i)
6414	write(,) 'h(i,nk(i))=',h(i,nk(i))
6415	write(,) 'lv(i,k)=',lv(i,k)
6416	write(,) 't(i,k)=',t(i,k)
6417	write(,) 'clw(i,k)=',clw(i,k)
6418	write(,) 'cpd,cpv=',cpd,cpv
6419	CALL abort_physic(modname,abort_message,0)
6420	endif
6421	enddo !do k=1,nl
6422	enddo !do i=1,ncum
6423	endif !if (coef_epmax_cape.gt.1e-12) then
6424
6425	return
6426	end subroutine cv30_epmax_fn_cape
6427
6428

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

Download in other formats:

Original Format