Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

cv30_routines.F90

Last change on this file was 4491, checked in by crisi, 14 months ago
Bug corrections in LMDZiso, especially for water tagging
Property svn:keywords set to `Id`
File size: 217.8 KB

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

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

Download in other formats:

Original Format