Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

cv30_routines.F90 @ 5427

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

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

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

Download in other formats:

Original Format