Context Navigation

lmdz_cv30.F90 @ 5182

Last change on this file since 5182 was 5159, checked in by abarral, 3 months ago
Put dimensions.h and paramet.h into modules
Property svn:keywords set to `Id`
File size: 218.0 KB

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

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

Download in other formats:

Original Format