Context Navigation

cv30_routines.F90 @ 5119

Last change on this file since 5119 was 5117, checked in by abarral, 2 months ago
rename modules properly lmdz_* move some unused files to obsolete/ (lint) uppercase fortran keywords
Property svn:keywords set to `Id`
File size: 217.0 KB

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

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

Download in other formats:

Original Format