Context Navigation

cv30_routines_mod.F90

Last change on this file was 5283, checked in by abarral, 3 weeks ago
Turn tracstoke.h conema3.h cv30_routines.f90 cv30param.h into modules
Property svn:keywords set to `Id`
File size: 216.4 KB

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

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

Download in other formats:

Original Format