source: LMDZ6/branches/Ocean_skin/libf/phylmdiso/cv30_routines.F90 @ 5456

Last change on this file since 5456 was 4368, checked in by lguez, 2 years ago

Sync latest trunk changes to Ocean_skin

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