Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

cv3_routines.F90 @ 5452

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

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

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

Download in other formats:

Original Format