Context Navigation

cv30_routines.F90 @ 5275

Last change on this file since 5275 was 5275, checked in by abarral, 22 hours ago
Turn cvflag.h into a module
Property svn:keywords set to `Id`
File size: 218.2 KB

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

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

Download in other formats:

Original Format