Changeset 5283 for LMDZ6/trunk/libf


Ignore:
Timestamp:
Oct 28, 2024, 1:47:34 PM (4 days ago)
Author:
abarral
Message:

Turn tracstoke.h conema3.h cv30_routines.f90 cv30param.h into modules

Location:
LMDZ6/trunk/libf
Files:
2 deleted
20 edited
6 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/trunk/libf/dyn3d/fluxstokenc.f90

    r5282 r5283  
    1515  !cc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
    1616  !
     17  USE tracstoke_mod_h
    1718  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
    1819USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
    … …  
    2223
    2324
    24   include "tracstoke.h"
    2525
    2626  REAL :: time_step,t_wrt, t_ops

  • LMDZ6/trunk/libf/dyn3d/gcm.f90

    r5282 r5283  
    2828  USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
    2929          ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
     30  USE tracstoke_mod_h
    3031  IMPLICIT NONE
    3132
    … …  
    5960  !   Declarations:
    6061  !   -------------
    61   include "tracstoke.h"
    6262
    6363  REAL zdtvr

  • LMDZ6/trunk/libf/dyn3d_common/tracstoke_mod_h.f90

    r5282 r5283  
    1 !
    2 ! $Header$
    3 !
    4       common /tracstoke/istdyn,istphy,unittrac
    5       integer istdyn,istphy,unittrac
     1! Replaces tracstoke.h
     2MODULE tracstoke_mod_h
     3  IMPLICIT NONE; PRIVATE
     4  PUBLIC istdyn, istphy, unittrac
     5
     6  INTEGER istdyn, istphy, unittrac
     7END MODULE tracstoke_mod_h

  • LMDZ6/trunk/libf/dyn3dmem/fluxstokenc_p.f90

    r5272 r5283  
    66      SUBROUTINE fluxstokenc_p(pbaru,pbarv , &
    77              masse,  teta, phi)
     8  USE tracstoke_mod_h
    89  USE parallel_lmdz
    910  USE control_mod, ONLY : iapp_tracvl,planet_type,iphysiq
    … …  
    3233
    3334
    34   include "tracstoke.h"
    3535
    3636  !   Arguments:

  • LMDZ6/trunk/libf/dyn3dmem/gcm.F90

    r5282 r5283  
    3232  USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
    3333          ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
     34  USE tracstoke_mod_h
    3435IMPLICIT NONE
    3536
    … …  
    6364  !   Declarations:
    6465  !   -------------
    65   include "tracstoke.h"
    66 
    67 
    6866  REAL zdtvr
    6967

  • LMDZ6/trunk/libf/dynphy_lonlat/phylmd/iniphysiq_mod.F90

    r5282 r5283  
    3838  USE bands, ONLY : distrib_phys
    3939#endif
     40  USE tracstoke_mod_h
    4041  USE iniprint_mod_h
    4142  USE comgeom_mod_h
    … …  
    5657
    5758
    58   include "tracstoke.h"
    5959
    6060  REAL, INTENT (IN) :: prad ! radius of the planet (m)

  • LMDZ6/trunk/libf/phylmd/concvl.f90

    r5282 r5283  
    4747          , RESTT, RALPW, RBETW, RGAMW, RALPS, RBETS, RGAMS            &
    4848          , RALPD, RBETD, RGAMD
     49  USE conema3_mod_h
    4950  IMPLICIT NONE
    5051! ======================================================================
    … …  
    238239  include "YOETHF.h"
    239240  include "FCTTRE.h"
    240 !jyg<
    241   include "conema3.h"
    242 !>jyg
    243241
    244242  IF (first) THEN

  • LMDZ6/trunk/libf/phylmd/conema3.f90

    r5274 r5283  
    2121          , RESTT, RALPW, RBETW, RGAMW, RALPS, RBETS, RGAMS            &
    2222          , RALPD, RBETD, RGAMD
     23  USE conema3_mod_h
    2324  IMPLICIT NONE
    2425  ! ======================================================================
    … …  
    6566  ! ======================================================================
    6667
    67   include "conema3.h"
    6868  INTEGER i, l, m, itra
    6969  INTEGER ntra ! if no tracer transport

  • LMDZ6/trunk/libf/phylmd/conema3_mod_h.f90

    r5282 r5283  
    1 !
    2 ! $Header$
    3 !-- Modified by : Filiberti M-A 06/2005
    4 !
    5       real epmax             ! 0.993
    6       real coef_epmax_cape             ! 0.993
    7 !jyg<
    8       REAL  cvl_comp_threshold     ! 0.
    9 !>jyg
    10       logical ok_adj_ema      ! F
    11       integer iflag_clw      ! 0
    12       integer iflag_cvl_sigd
    13       real cvl_sig2feed      ! 0.97
     1MODULE conema3_mod_h
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC epmax, coef_epmax_cape, cvl_comp_threshold, cvl_sig2feed
     4  PUBLIC iflag_cvl_sigd, iflag_clw, ok_adj_ema
    145
    15 !jyg<
    16 !!      common/comconema1/epmax,coef_epmax_cape,ok_adj_ema,iflag_clw,sig1feed,sig2feed
    17 !!      common/comconema2/iflag_cvl_sigd
    18       common/comconema1/epmax,coef_epmax_cape, cvl_comp_threshold, cvl_sig2feed
    19       common/comconema2/iflag_cvl_sigd, iflag_clw, ok_adj_ema
    20 !>jyg
     6  REAL epmax             ! 0.993
     7  REAL coef_epmax_cape             ! 0.993
     8  REAL  cvl_comp_threshold     ! 0.
     9  LOGICAL ok_adj_ema      ! F
     10  INTEGER iflag_clw      ! 0
     11  INTEGER iflag_cvl_sigd
     12  REAL cvl_sig2feed      ! 0.97
    2113
    22 !      common/comconema/epmax,coef_epmax_cape,ok_adj_ema,iflag_clw
    23 !$OMP THREADPRIVATE(/comconema1/)
    24 !$OMP THREADPRIVATE(/comconema2/)
    25 
     14  !$OMP THREADPRIVATE(epmax,coef_epmax_cape, cvl_comp_threshold, cvl_sig2feed)
     15  !$OMP THREADPRIVATE(iflag_cvl_sigd, iflag_clw, ok_adj_ema)
     16END MODULE conema3_mod_h

  • LMDZ6/trunk/libf/phylmd/conf_phys_m.f90

    r5282 r5283  
    2424       alp_offset)
    2525
    26     USE yomcst_mod_h, ONLY: RPI, RCLUM, RHPLA, RKBOL, RNAVO                   &
     26USE conema3_mod_h
     27        USE yomcst_mod_h, ONLY: RPI, RCLUM, RHPLA, RKBOL, RNAVO                   &
    2728          , RDAY, REA, REPSM, RSIYEA, RSIDAY, ROMEGA                  &
    2829          , R_ecc, R_peri, R_incl                                      &
    … …  
    5051    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_STRATAER
    5152
    52     INCLUDE "conema3.h"
    5353    INCLUDE "nuage.h"
    5454

  • LMDZ6/trunk/libf/phylmd/cv30_routines_mod.f90

    r5282 r5283  
    1 
    2 ! $Id$
    3 
    4 
    5 
    6 SUBROUTINE cv30_param(nd, delt)
    7   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    8           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    9   IMPLICIT NONE
    10 
    11   ! ------------------------------------------------------------
    12   ! Set parameters for convectL for iflag_con = 3
    13   ! ------------------------------------------------------------
    14 
    15 
    16   ! ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
    17   ! ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
    18   ! ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***
    19   ! ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
    20   ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
    21   ! ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
    22   ! ***                        OF CLOUD                         ***
    23 
    24   ! [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
    25   ! ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
    26   ! ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
    27   ! ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
    28   ! ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
    29 
    30   ! ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
    31   ! ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
    32   ! ***                     IT MUST BE LESS THAN 0              ***
    33 
    34   include "cv30param.h"
    35   include "conema3.h"
    36 
    37   INTEGER nd
    38   REAL delt ! timestep (seconds)
    39 
    40   ! noff: integer limit for convection (nd-noff)
    41   ! minorig: First level of convection
    42 
    43   ! -- limit levels for convection:
    44 
    45   noff = 1
    46   minorig = 1
    47   nl = nd - noff
    48   nlp = nl + 1
    49   nlm = nl - 1
    50 
    51   ! -- "microphysical" parameters:
    52 
    53   sigd = 0.01
    54   spfac = 0.15
    55   pbcrit = 150.0
    56   ptcrit = 500.0
    57   ! IM cf. FH     epmax  = 0.993
    58 
    59   omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
    60 
    61   ! -- misc:
    62 
    63   dtovsh = -0.2 ! dT for overshoot
    64   dpbase = -40. ! definition cloud base (400m above LCL)
    65   dttrig = 5. ! (loose) condition for triggering
    66 
    67   ! -- rate of approach to quasi-equilibrium:
    68 
    69   dtcrit = -2.0
    70   tau = 8000.
    71   beta = 1.0 - delt/tau
    72   alpha = 1.5E-3*delt/tau
    73   ! increase alpha to compensate W decrease:
    74   alpha = alpha*1.5
    75 
    76   ! -- interface cloud parameterization:
    77 
    78   delta = 0.01 ! cld
    79 
    80   ! -- interface with boundary-layer (gust factor): (sb)
    81 
    82   betad = 10.0 ! original value (from convect 4.3)
    83 
    84   RETURN
    85 END SUBROUTINE cv30_param
    86 
    87 SUBROUTINE cv30_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm, &
    88     th)
    89   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    90           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    91   IMPLICIT NONE
    92 
    93   ! =====================================================================
    94   ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
    95   ! "ori": from convect4.3 (vectorized)
    96   ! "convect3": to be exactly consistent with convect3
    97   ! =====================================================================
    98 
    99   ! inputs:
    100   INTEGER len, nd, ndp1
    101   REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
    102 
    103   ! outputs:
    104   REAL lv(len, nd), cpn(len, nd), tv(len, nd)
    105   REAL gz(len, nd), h(len, nd), hm(len, nd)
    106   REAL th(len, nd)
    107 
    108   ! local variables:
    109   INTEGER k, i
    110   REAL rdcp
    111   REAL tvx, tvy ! convect3
    112   REAL cpx(len, nd)
    113 
    114   include "cv30param.h"
    115 
    116 
    117   ! ori      do 110 k=1,nlp
    118   DO k = 1, nl ! convect3
     1MODULE cv30_routines_mod
     2  !------------------------------------------------------------
     3  ! Parameters for convectL, iflag_con=30:
     4  ! (includes - microphysical parameters,
     5  !            - parameters that control the rate of approach
     6  !               to quasi-equilibrium)
     7  !            - noff & minorig (previously in input of convect1)
     8  !------------------------------------------------------------
     9
     10  IMPLICIT NONE; PRIVATE
     11  PUBLIC sigd, spfac, pbcrit, ptcrit, omtrain, dtovsh, dpbase, dttrig, dtcrit, &
     12          tau, beta, alpha, delta, betad, noff, minorig, nl, nlp, nlm, &
     13          cv30_param, cv30_prelim, cv30_feed, cv30_undilute1, cv30_trigger, &
     14          cv30_compress, cv30_undilute2, cv30_closure, cv30_mixing, cv30_unsat, &
     15          cv30_yield, cv30_tracer, cv30_uncompress, cv30_epmax_fn_cape
     16
     17  INTEGER noff, minorig, nl, nlp, nlm
     18  REAL sigd, spfac
     19  REAL pbcrit, ptcrit
     20  REAL omtrain
     21  REAL dtovsh, dpbase, dttrig
     22  REAL dtcrit, tau, beta, alpha
     23  REAL delta
     24  REAL betad
     25
     26  !$OMP THREADPRIVATE(sigd, spfac, pbcrit, ptcrit, omtrain, dtovsh, dpbase, dttrig, dtcrit, &
     27  !$OMP      tau, beta, alpha, delta, betad, noff, minorig, nl, nlp, nlm)
     28CONTAINS
     29
     30  SUBROUTINE cv30_param(nd, delt)
     31    USE conema3_mod_h
     32
     33    IMPLICIT NONE
     34
     35    ! ------------------------------------------------------------
     36    ! Set parameters for convectL for iflag_con = 3
     37    ! ------------------------------------------------------------
     38
     39
     40    ! ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
     41    ! ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
     42    ! ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***
     43    ! ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
     44    ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
     45    ! ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
     46    ! ***                        OF CLOUD                         ***
     47
     48    ! [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
     49    ! ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
     50    ! ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
     51    ! ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
     52    ! ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
     53
     54    ! ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
     55    ! ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
     56    ! ***                     IT MUST BE LESS THAN 0              ***
     57
     58    INTEGER nd
     59    REAL delt ! timestep (seconds)
     60
     61    ! noff: integer limit for convection (nd-noff)
     62    ! minorig: First level of convection
     63
     64    ! -- limit levels for convection:
     65
     66    noff = 1
     67    minorig = 1
     68    nl = nd - noff
     69    nlp = nl + 1
     70    nlm = nl - 1
     71
     72    ! -- "microphysical" parameters:
     73
     74    sigd = 0.01
     75    spfac = 0.15
     76    pbcrit = 150.0
     77    ptcrit = 500.0
     78    ! IM cf. FH     epmax  = 0.993
     79
     80    omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
     81
     82    ! -- misc:
     83
     84    dtovsh = -0.2 ! dT for overshoot
     85    dpbase = -40. ! definition cloud base (400m above LCL)
     86    dttrig = 5. ! (loose) condition for triggering
     87
     88    ! -- rate of approach to quasi-equilibrium:
     89
     90    dtcrit = -2.0
     91    tau = 8000.
     92    beta = 1.0 - delt / tau
     93    alpha = 1.5E-3 * delt / tau
     94    ! increase alpha to compensate W decrease:
     95    alpha = alpha * 1.5
     96
     97    ! -- interface cloud parameterization:
     98
     99    delta = 0.01 ! cld
     100
     101    ! -- interface with boundary-layer (gust factor): (sb)
     102
     103    betad = 10.0 ! original value (from convect 4.3)
     104
     105  END SUBROUTINE cv30_param
     106
     107  SUBROUTINE cv30_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm, &
     108          th)
     109    USE cvthermo_mod_h
     110
     111    IMPLICIT NONE
     112
     113    ! =====================================================================
     114    ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
     115    ! "ori": from convect4.3 (vectorized)
     116    ! "convect3": to be exactly consistent with convect3
     117    ! =====================================================================
     118
     119    ! inputs:
     120    INTEGER len, nd, ndp1
     121    REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
     122
     123    ! outputs:
     124    REAL lv(len, nd), cpn(len, nd), tv(len, nd)
     125    REAL gz(len, nd), h(len, nd), hm(len, nd)
     126    REAL th(len, nd)
     127
     128    ! local variables:
     129    INTEGER k, i
     130    REAL rdcp
     131    REAL tvx, tvy ! convect3
     132    REAL cpx(len, nd)
     133
     134    ! ori      do 110 k=1,nlp
     135    DO k = 1, nl ! convect3
     136      DO i = 1, len
     137        ! debug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
     138        lv(i, k) = lv0 - clmcpv * (t(i, k) - 273.15)
     139        cpn(i, k) = cpd * (1.0 - q(i, k)) + cpv * q(i, k)
     140        cpx(i, k) = cpd * (1.0 - q(i, k)) + cl * q(i, k)
     141        ! ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
     142        tv(i, k) = t(i, k) * (1.0 + q(i, k) / eps - q(i, k))
     143        rdcp = (rrd * (1. - q(i, k)) + q(i, k) * rrv) / cpn(i, k)
     144        th(i, k) = t(i, k) * (1000.0 / p(i, k))**rdcp
     145      END DO
     146    END DO
     147
     148    ! gz = phi at the full levels (same as p).
     149
    119150    DO i = 1, len
    120       ! debug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
    121       lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15)
    122       cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
    123       cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
    124       ! ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
    125       tv(i, k) = t(i, k)*(1.0+q(i,k)/eps-q(i,k))
    126       rdcp = (rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i, k)
    127       th(i, k) = t(i, k)*(1000.0/p(i,k))**rdcp
    128     END DO
    129   END DO
    130 
    131   ! gz = phi at the full levels (same as p).
    132 
    133   DO i = 1, len
    134     gz(i, 1) = 0.0
    135   END DO
    136   ! ori      do 140 k=2,nlp
    137   DO k = 2, nl ! convect3
     151      gz(i, 1) = 0.0
     152    END DO
     153    ! ori      do 140 k=2,nlp
     154    DO k = 2, nl ! convect3
     155      DO i = 1, len
     156        tvx = t(i, k) * (1. + q(i, k) / eps - q(i, k)) !convect3
     157        tvy = t(i, k - 1) * (1. + q(i, k - 1) / eps - q(i, k - 1)) !convect3
     158        gz(i, k) = gz(i, k - 1) + 0.5 * rrd * (tvx + tvy) & !convect3
     159                * (p(i, k - 1) - p(i, k)) / ph(i, k) !convect3
     160
     161        ! ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
     162        ! ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
     163      END DO
     164    END DO
     165
     166    ! h  = phi + cpT (dry static energy).
     167    ! hm = phi + cp(T-Tbase)+Lq
     168
     169    ! ori      do 170 k=1,nlp
     170    DO k = 1, nl ! convect3
     171      DO i = 1, len
     172        h(i, k) = gz(i, k) + cpn(i, k) * t(i, k)
     173        hm(i, k) = gz(i, k) + cpx(i, k) * (t(i, k) - t(i, 1)) + lv(i, k) * q(i, k)
     174      END DO
     175    END DO
     176
     177  END SUBROUTINE cv30_prelim
     178
     179  SUBROUTINE cv30_feed(len, nd, t, q, qs, p, ph, hm, gz, nk, icb, icbmax, &
     180          iflag, tnk, qnk, gznk, plcl)
     181
     182    IMPLICIT NONE
     183
     184    ! ================================================================
     185    ! Purpose: CONVECTIVE FEED
     186
     187    ! Main differences with cv_feed:
     188    ! - ph added in input
     189    ! - here, nk(i)=minorig
     190    ! - icb defined differently (plcl compared with ph instead of p)
     191
     192    ! Main differences with convect3:
     193    ! - we do not compute dplcldt and dplcldr of CLIFT anymore
     194    ! - values iflag different (but tests identical)
     195    ! - A,B explicitely defined (!...)
     196    ! ================================================================
     197
     198    ! inputs:
     199    INTEGER len, nd
     200    REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd)
     201    REAL hm(len, nd), gz(len, nd)
     202    REAL ph(len, nd + 1)
     203
     204    ! outputs:
     205    INTEGER iflag(len), nk(len), icb(len), icbmax
     206    REAL tnk(len), qnk(len), gznk(len), plcl(len)
     207
     208    ! local variables:
     209    INTEGER i, k
     210    INTEGER ihmin(len)
     211    REAL work(len)
     212    REAL pnk(len), qsnk(len), rh(len), chi(len)
     213    REAL a, b ! convect3
     214    ! ym
     215    plcl = 0.0
     216    ! @ !-------------------------------------------------------------------
     217    ! @ ! --- Find level of minimum moist static energy
     218    ! @ ! --- If level of minimum moist static energy coincides with
     219    ! @ ! --- or is lower than minimum allowable parcel origin level,
     220    ! @ ! --- set iflag to 6.
     221    ! @ !-------------------------------------------------------------------
     222    ! @
     223    ! @       do 180 i=1,len
     224    ! @        work(i)=1.0e12
     225    ! @        ihmin(i)=nl
     226    ! @  180  continue
     227    ! @       do 200 k=2,nlp
     228    ! @         do 190 i=1,len
     229    ! @          if((hm(i,k).lt.work(i)).AND.
     230    ! @      &      (hm(i,k).lt.hm(i,k-1)))THEN
     231    ! @            work(i)=hm(i,k)
     232    ! @            ihmin(i)=k
     233    ! @          endif
     234    ! @  190    continue
     235    ! @  200  continue
     236    ! @       do 210 i=1,len
     237    ! @         ihmin(i)=min(ihmin(i),nlm)
     238    ! @         IF(ihmin(i).le.minorig)THEN
     239    ! @           iflag(i)=6
     240    ! @         endif
     241    ! @  210  continue
     242    ! @ c
     243    ! @ !-------------------------------------------------------------------
     244    ! @ ! --- Find that model level below the level of minimum moist static
     245    ! @ ! --- energy that has the maximum value of moist static energy
     246    ! @ !-------------------------------------------------------------------
     247    ! @
     248    ! @       do 220 i=1,len
     249    ! @        work(i)=hm(i,minorig)
     250    ! @        nk(i)=minorig
     251    ! @  220  continue
     252    ! @       do 240 k=minorig+1,nl
     253    ! @         do 230 i=1,len
     254    ! @          if((hm(i,k).gt.work(i)).AND.(k.le.ihmin(i)))THEN
     255    ! @            work(i)=hm(i,k)
     256    ! @            nk(i)=k
     257    ! @          endif
     258    ! @  230     continue
     259    ! @  240  continue
     260
     261    ! -------------------------------------------------------------------
     262    ! --- Origin level of ascending parcels for convect3:
     263    ! -------------------------------------------------------------------
     264
    138265    DO i = 1, len
    139       tvx = t(i, k)*(1.+q(i,k)/eps-q(i,k)) !convect3
    140       tvy = t(i, k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
    141       gz(i, k) = gz(i, k-1) + 0.5*rrd*(tvx+tvy) & !convect3
    142         *(p(i,k-1)-p(i,k))/ph(i, k) !convect3
    143 
    144       ! ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
    145       ! ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
    146     END DO
    147   END DO
    148 
    149   ! h  = phi + cpT (dry static energy).
    150   ! hm = phi + cp(T-Tbase)+Lq
    151 
    152   ! ori      do 170 k=1,nlp
    153   DO k = 1, nl ! convect3
     266      nk(i) = minorig
     267    END DO
     268
     269    ! -------------------------------------------------------------------
     270    ! --- Check whether parcel level temperature and specific humidity
     271    ! --- are reasonable
     272    ! -------------------------------------------------------------------
    154273    DO i = 1, len
    155       h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
    156       hm(i, k) = gz(i, k) + cpx(i, k)*(t(i,k)-t(i,1)) + lv(i, k)*q(i, k)
    157     END DO
    158   END DO
    159 
    160   RETURN
    161 END SUBROUTINE cv30_prelim
    162 
    163 SUBROUTINE cv30_feed(len, nd, t, q, qs, p, ph, hm, gz, nk, icb, icbmax, &
    164     iflag, tnk, qnk, gznk, plcl)
    165   IMPLICIT NONE
    166 
    167   ! ================================================================
    168   ! Purpose: CONVECTIVE FEED
    169 
    170   ! Main differences with cv_feed:
    171   ! - ph added in input
    172   ! - here, nk(i)=minorig
    173   ! - icb defined differently (plcl compared with ph instead of p)
    174 
    175   ! Main differences with convect3:
    176   ! - we do not compute dplcldt and dplcldr of CLIFT anymore
    177   ! - values iflag different (but tests identical)
    178   ! - A,B explicitely defined (!...)
    179   ! ================================================================
    180 
    181   include "cv30param.h"
    182 
    183   ! inputs:
    184   INTEGER len, nd
    185   REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd)
    186   REAL hm(len, nd), gz(len, nd)
    187   REAL ph(len, nd+1)
    188 
    189   ! outputs:
    190   INTEGER iflag(len), nk(len), icb(len), icbmax
    191   REAL tnk(len), qnk(len), gznk(len), plcl(len)
    192 
    193   ! local variables:
    194   INTEGER i, k
    195   INTEGER ihmin(len)
    196   REAL work(len)
    197   REAL pnk(len), qsnk(len), rh(len), chi(len)
    198   REAL a, b ! convect3
    199   ! ym
    200   plcl = 0.0
    201   ! @ !-------------------------------------------------------------------
    202   ! @ ! --- Find level of minimum moist static energy
    203   ! @ ! --- If level of minimum moist static energy coincides with
    204   ! @ ! --- or is lower than minimum allowable parcel origin level,
    205   ! @ ! --- set iflag to 6.
    206   ! @ !-------------------------------------------------------------------
    207   ! @
    208   ! @       do 180 i=1,len
    209   ! @        work(i)=1.0e12
    210   ! @        ihmin(i)=nl
    211   ! @  180  continue
    212   ! @       do 200 k=2,nlp
    213   ! @         do 190 i=1,len
    214   ! @          if((hm(i,k).lt.work(i)).and.
    215   ! @      &      (hm(i,k).lt.hm(i,k-1)))then
    216   ! @            work(i)=hm(i,k)
    217   ! @            ihmin(i)=k
    218   ! @          endif
    219   ! @  190    continue
    220   ! @  200  continue
    221   ! @       do 210 i=1,len
    222   ! @         ihmin(i)=min(ihmin(i),nlm)
    223   ! @         if(ihmin(i).le.minorig)then
    224   ! @           iflag(i)=6
    225   ! @         endif
    226   ! @  210  continue
    227   ! @ c
    228   ! @ !-------------------------------------------------------------------
    229   ! @ ! --- Find that model level below the level of minimum moist static
    230   ! @ ! --- energy that has the maximum value of moist static energy
    231   ! @ !-------------------------------------------------------------------
    232   ! @
    233   ! @       do 220 i=1,len
    234   ! @        work(i)=hm(i,minorig)
    235   ! @        nk(i)=minorig
    236   ! @  220  continue
    237   ! @       do 240 k=minorig+1,nl
    238   ! @         do 230 i=1,len
    239   ! @          if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
    240   ! @            work(i)=hm(i,k)
    241   ! @            nk(i)=k
    242   ! @          endif
    243   ! @  230     continue
    244   ! @  240  continue
    245 
    246   ! -------------------------------------------------------------------
    247   ! --- Origin level of ascending parcels for convect3:
    248   ! -------------------------------------------------------------------
    249 
    250   DO i = 1, len
    251     nk(i) = minorig
    252   END DO
    253 
    254   ! -------------------------------------------------------------------
    255   ! --- Check whether parcel level temperature and specific humidity
    256   ! --- are reasonable
    257   ! -------------------------------------------------------------------
    258   DO i = 1, len
    259     IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0)) & ! @      &       .or.(
    260                                                       ! p(i,ihmin(i)).lt.400.0
    261                                                       ! )  )
    262       .AND. (iflag(i)==0)) iflag(i) = 7
    263   END DO
    264   ! -------------------------------------------------------------------
    265   ! --- Calculate lifted condensation level of air at parcel origin level
    266   ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
    267   ! -------------------------------------------------------------------
    268 
    269   a = 1669.0 ! convect3
    270   b = 122.0 ! convect3
    271 
    272   DO i = 1, len
    273 
    274     IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
    275 
     274      IF (((t(i, nk(i))<250.0) .OR. (q(i, nk(i))<=0.0)) & ! @      &       .OR.(
     275              ! p(i,ihmin(i)).lt.400.0
     276              ! )  )
     277              .AND. (iflag(i)==0)) iflag(i) = 7
     278    END DO
     279    ! -------------------------------------------------------------------
     280    ! --- Calculate lifted condensation level of air at parcel origin level
     281    ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
     282    ! -------------------------------------------------------------------
     283
     284    a = 1669.0 ! convect3
     285    b = 122.0 ! convect3
     286
     287    DO i = 1, len
     288
     289      IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
     290
     291        tnk(i) = t(i, nk(i))
     292        qnk(i) = q(i, nk(i))
     293        gznk(i) = gz(i, nk(i))
     294        pnk(i) = p(i, nk(i))
     295        qsnk(i) = qs(i, nk(i))
     296
     297        rh(i) = qnk(i) / qsnk(i)
     298        ! ori        rh(i)=min(1.0,rh(i)) ! removed for convect3
     299        ! ori        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
     300        chi(i) = tnk(i) / (a - b * rh(i) - tnk(i)) ! convect3
     301        plcl(i) = pnk(i) * (rh(i)**chi(i))
     302        IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag &
     303                (i) = 8
     304
     305      END IF ! iflag=7
     306
     307    END DO
     308
     309    ! -------------------------------------------------------------------
     310    ! --- Calculate first level above lcl (=icb)
     311    ! -------------------------------------------------------------------
     312
     313    ! @      do 270 i=1,len
     314    ! @       icb(i)=nlm
     315    ! @ 270  continue
     316    ! @c
     317    ! @      do 290 k=minorig,nl
     318    ! @        do 280 i=1,len
     319    ! @          if((k.ge.(nk(i)+1)).AND.(p(i,k).lt.plcl(i)))
     320    ! @     &    icb(i)=min(icb(i),k)
     321    ! @ 280    continue
     322    ! @ 290  continue
     323    ! @c
     324    ! @      do 300 i=1,len
     325    ! @        if((icb(i).ge.nlm).AND.(iflag(i).EQ.0))iflag(i)=9
     326    ! @ 300  continue
     327
     328    DO i = 1, len
     329      icb(i) = nlm
     330    END DO
     331
     332    ! la modification consiste a comparer plcl a ph et non a p:
     333    ! icb est defini par :  ph(icb)<plcl<ph(icb-1)
     334    ! @      do 290 k=minorig,nl
     335    DO k = 3, nl - 1 ! modif pour que icb soit sup/egal a 2
     336      DO i = 1, len
     337        IF (ph(i, k)<plcl(i)) icb(i) = min(icb(i), k)
     338      END DO
     339    END DO
     340
     341    DO i = 1, len
     342      ! @        if((icb(i).ge.nlm).AND.(iflag(i).EQ.0))iflag(i)=9
     343      IF ((icb(i)==nlm) .AND. (iflag(i)==0)) iflag(i) = 9
     344    END DO
     345
     346    DO i = 1, len
     347      icb(i) = icb(i) - 1 ! icb sup ou egal a 2
     348    END DO
     349
     350    ! Compute icbmax.
     351
     352    icbmax = 2
     353    DO i = 1, len
     354      !        icbmax=max(icbmax,icb(i))
     355      IF (iflag(i)<7) icbmax = max(icbmax, icb(i)) ! sb Jun7th02
     356    END DO
     357
     358  END SUBROUTINE cv30_feed
     359
     360  SUBROUTINE cv30_undilute1(len, nd, t, q, qs, gz, plcl, p, nk, icb, tp, tvp, &
     361          clw, icbs)
     362    USE cvthermo_mod_h
     363
     364    IMPLICIT NONE
     365
     366    ! ----------------------------------------------------------------
     367    ! Equivalent de TLIFT entre NK et ICB+1 inclus
     368
     369    ! Differences with convect4:
     370    ! - specify plcl in input
     371    ! - icbs is the first level above LCL (may differ from icb)
     372    ! - in the iterations, used x(icbs) instead x(icb)
     373    ! - many minor differences in the iterations
     374    ! - tvp is computed in only one time
     375    ! - icbs: first level above Plcl (IMIN de TLIFT) in output
     376    ! - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
     377    ! ----------------------------------------------------------------
     378
     379
     380
     381    ! inputs:
     382    INTEGER len, nd
     383    INTEGER nk(len), icb(len)
     384    REAL t(len, nd), q(len, nd), qs(len, nd), gz(len, nd)
     385    REAL p(len, nd)
     386    REAL plcl(len) ! convect3
     387
     388    ! outputs:
     389    REAL tp(len, nd), tvp(len, nd), clw(len, nd)
     390
     391    ! local variables:
     392    INTEGER i, k
     393    INTEGER icb1(len), icbs(len), icbsmax2 ! convect3
     394    REAL tg, qg, alv, s, ahg, tc, denom, es, rg
     395    REAL ah0(len), cpp(len)
     396    REAL tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
     397    REAL qsicb(len) ! convect3
     398    REAL cpinv(len) ! convect3
     399
     400    ! -------------------------------------------------------------------
     401    ! --- Calculates the lifted parcel virtual temperature at nk,
     402    ! --- the actual temperature, and the adiabatic
     403    ! --- liquid water content. The procedure is to solve the equation.
     404    ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
     405    ! -------------------------------------------------------------------
     406
     407    DO i = 1, len
    276408      tnk(i) = t(i, nk(i))
    277409      qnk(i) = q(i, nk(i))
    278410      gznk(i) = gz(i, nk(i))
    279       pnk(i) = p(i, nk(i))
    280       qsnk(i) = qs(i, nk(i))
    281 
    282       rh(i) = qnk(i)/qsnk(i)
    283       ! ori        rh(i)=min(1.0,rh(i)) ! removed for convect3
    284       ! ori        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
    285       chi(i) = tnk(i)/(a-b*rh(i)-tnk(i)) ! convect3
    286       plcl(i) = pnk(i)*(rh(i)**chi(i))
    287       IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag &
    288         (i) = 8
    289 
    290     END IF ! iflag=7
    291 
    292   END DO
    293 
    294   ! -------------------------------------------------------------------
    295   ! --- Calculate first level above lcl (=icb)
    296   ! -------------------------------------------------------------------
    297 
    298   ! @      do 270 i=1,len
    299   ! @       icb(i)=nlm
    300   ! @ 270  continue
    301   ! @c
    302   ! @      do 290 k=minorig,nl
    303   ! @        do 280 i=1,len
    304   ! @          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
    305   ! @     &    icb(i)=min(icb(i),k)
    306   ! @ 280    continue
    307   ! @ 290  continue
    308   ! @c
    309   ! @      do 300 i=1,len
    310   ! @        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
    311   ! @ 300  continue
    312 
    313   DO i = 1, len
    314     icb(i) = nlm
    315   END DO
    316 
    317   ! la modification consiste a comparer plcl a ph et non a p:
    318   ! icb est defini par :  ph(icb)<plcl<ph(icb-1)
    319   ! @      do 290 k=minorig,nl
    320   DO k = 3, nl - 1 ! modif pour que icb soit sup/egal a 2
     411      ! ori        ticb(i)=t(i,icb(i))
     412      ! ori        gzicb(i)=gz(i,icb(i))
     413    END DO
     414
     415    ! ***  Calculate certain parcel quantities, including static energy   ***
     416
    321417    DO i = 1, len
    322       IF (ph(i,k)<plcl(i)) icb(i) = min(icb(i), k)
    323     END DO
    324   END DO
    325 
    326   DO i = 1, len
    327     ! @        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
    328     IF ((icb(i)==nlm) .AND. (iflag(i)==0)) iflag(i) = 9
    329   END DO
    330 
    331   DO i = 1, len
    332     icb(i) = icb(i) - 1 ! icb sup ou egal a 2
    333   END DO
    334 
    335   ! Compute icbmax.
    336 
    337   icbmax = 2
    338   DO i = 1, len
    339     ! !        icbmax=max(icbmax,icb(i))
    340     IF (iflag(i)<7) icbmax = max(icbmax, icb(i)) ! sb Jun7th02
    341   END DO
    342 
    343   RETURN
    344 END SUBROUTINE cv30_feed
    345 
    346 SUBROUTINE cv30_undilute1(len, nd, t, q, qs, gz, plcl, p, nk, icb, tp, tvp, &
    347     clw, icbs)
    348   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    349           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    350   IMPLICIT NONE
    351 
    352   ! ----------------------------------------------------------------
    353   ! Equivalent de TLIFT entre NK et ICB+1 inclus
    354 
    355   ! Differences with convect4:
    356   ! - specify plcl in input
    357   ! - icbs is the first level above LCL (may differ from icb)
    358   ! - in the iterations, used x(icbs) instead x(icb)
    359   ! - many minor differences in the iterations
    360   ! - tvp is computed in only one time
    361   ! - icbs: first level above Plcl (IMIN de TLIFT) in output
    362   ! - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
    363   ! ----------------------------------------------------------------
    364   include "cv30param.h"
    365 
    366   ! inputs:
    367   INTEGER len, nd
    368   INTEGER nk(len), icb(len)
    369   REAL t(len, nd), q(len, nd), qs(len, nd), gz(len, nd)
    370   REAL p(len, nd)
    371   REAL plcl(len) ! convect3
    372 
    373   ! outputs:
    374   REAL tp(len, nd), tvp(len, nd), clw(len, nd)
    375 
    376   ! local variables:
    377   INTEGER i, k
    378   INTEGER icb1(len), icbs(len), icbsmax2 ! convect3
    379   REAL tg, qg, alv, s, ahg, tc, denom, es, rg
    380   REAL ah0(len), cpp(len)
    381   REAL tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
    382   REAL qsicb(len) ! convect3
    383   REAL cpinv(len) ! convect3
    384 
    385   ! -------------------------------------------------------------------
    386   ! --- Calculates the lifted parcel virtual temperature at nk,
    387   ! --- the actual temperature, and the adiabatic
    388   ! --- liquid water content. The procedure is to solve the equation.
    389   ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
    390   ! -------------------------------------------------------------------
    391 
    392   DO i = 1, len
    393     tnk(i) = t(i, nk(i))
    394     qnk(i) = q(i, nk(i))
    395     gznk(i) = gz(i, nk(i))
    396     ! ori        ticb(i)=t(i,icb(i))
    397     ! ori        gzicb(i)=gz(i,icb(i))
    398   END DO
    399 
    400   ! ***  Calculate certain parcel quantities, including static energy   ***
    401 
    402   DO i = 1, len
    403     ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
    404       273.15)) + gznk(i)
    405     cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
    406     cpinv(i) = 1./cpp(i)
    407   END DO
    408 
    409   ! ***   Calculate lifted parcel quantities below cloud base   ***
    410 
    411   DO i = 1, len !convect3
    412     icb1(i) = min(max(icb(i), 2), nl)
    413     ! if icb is below LCL, start loop at ICB+1:
    414     ! (icbs est le premier niveau au-dessus du LCL)
    415     icbs(i) = icb1(i) !convect3
    416     IF (plcl(i)<p(i,icb1(i))) THEN
    417       icbs(i) = min(icbs(i)+1, nl) !convect3
     418      ah0(i) = (cpd * (1. - qnk(i)) + cl * qnk(i)) * tnk(i) + qnk(i) * (lv0 - clmcpv * (tnk(i) - &
     419              273.15)) + gznk(i)
     420      cpp(i) = cpd * (1. - qnk(i)) + qnk(i) * cpv
     421      cpinv(i) = 1. / cpp(i)
     422    END DO
     423
     424    ! ***   Calculate lifted parcel quantities below cloud base   ***
     425
     426    DO i = 1, len !convect3
     427      icb1(i) = min(max(icb(i), 2), nl)
     428      ! if icb is below LCL, start loop at ICB+1:
     429      ! (icbs est le premier niveau au-dessus du LCL)
     430      icbs(i) = icb1(i) !convect3
     431      IF (plcl(i)<p(i, icb1(i))) THEN
     432        icbs(i) = min(icbs(i) + 1, nl) !convect3
     433      END IF
     434    END DO !convect3
     435
     436    DO i = 1, len !convect3
     437      ticb(i) = t(i, icbs(i)) !convect3
     438      gzicb(i) = gz(i, icbs(i)) !convect3
     439      qsicb(i) = qs(i, icbs(i)) !convect3
     440    END DO !convect3
     441
     442
     443    ! Re-compute icbsmax (icbsmax2):        !convect3
     444    !convect3
     445    icbsmax2 = 2 !convect3
     446    DO i = 1, len !convect3
     447      icbsmax2 = max(icbsmax2, icbs(i)) !convect3
     448    END DO !convect3
     449
     450    ! initialization outputs:
     451
     452    DO k = 1, icbsmax2 ! convect3
     453      DO i = 1, len ! convect3
     454        tp(i, k) = 0.0 ! convect3
     455        tvp(i, k) = 0.0 ! convect3
     456        clw(i, k) = 0.0 ! convect3
     457      END DO ! convect3
     458    END DO ! convect3
     459
     460    ! tp and tvp below cloud base:
     461
     462    DO k = minorig, icbsmax2 - 1
     463      DO i = 1, len
     464        tp(i, k) = tnk(i) - (gz(i, k) - gznk(i)) * cpinv(i)
     465        tvp(i, k) = tp(i, k) * (1. + qnk(i) / eps - qnk(i)) !whole thing (convect3)
     466      END DO
     467    END DO
     468
     469    ! ***  Find lifted parcel quantities above cloud base    ***
     470
     471    DO i = 1, len
     472      tg = ticb(i)
     473      ! ori         qg=qs(i,icb(i))
     474      qg = qsicb(i) ! convect3
     475      ! debug         alv=lv0-clmcpv*(ticb(i)-t0)
     476      alv = lv0 - clmcpv * (ticb(i) - 273.15)
     477
     478      ! First iteration.
     479
     480      ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
     481      s = cpd * (1. - qnk(i)) + cl * qnk(i) & ! convect3
     482              + alv * alv * qg / (rrv * ticb(i) * ticb(i)) ! convect3
     483      s = 1. / s
     484      ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
     485      ahg = cpd * tg + (cl - cpd) * qnk(i) * tg + alv * qg + gzicb(i) ! convect3
     486      tg = tg + s * (ah0(i) - ahg)
     487      ! ori          tg=max(tg,35.0)
     488      ! debug          tc=tg-t0
     489      tc = tg - 273.15
     490      denom = 243.5 + tc
     491      denom = max(denom, 1.0) ! convect3
     492      ! ori          IF(tc.ge.0.0)THEN
     493      es = 6.112 * exp(17.67 * tc / denom)
     494      ! ori          else
     495      ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     496      ! ori          endif
     497      ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
     498      qg = eps * es / (p(i, icbs(i)) - es * (1. - eps))
     499
     500      ! Second iteration.
     501
     502
     503      ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
     504      ! ori          s=1./s
     505      ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
     506      ahg = cpd * tg + (cl - cpd) * qnk(i) * tg + alv * qg + gzicb(i) ! convect3
     507      tg = tg + s * (ah0(i) - ahg)
     508      ! ori          tg=max(tg,35.0)
     509      ! debug          tc=tg-t0
     510      tc = tg - 273.15
     511      denom = 243.5 + tc
     512      denom = max(denom, 1.0) ! convect3
     513      ! ori          IF(tc.ge.0.0)THEN
     514      es = 6.112 * exp(17.67 * tc / denom)
     515      ! ori          else
     516      ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     517      ! ori          end if
     518      ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
     519      qg = eps * es / (p(i, icbs(i)) - es * (1. - eps))
     520
     521      alv = lv0 - clmcpv * (ticb(i) - 273.15)
     522
     523      ! ori c approximation here:
     524      ! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
     525      ! ori     &   -gz(i,icb(i))-alv*qg)/cpd
     526
     527      ! convect3: no approximation:
     528      tp(i, icbs(i)) = (ah0(i) - gz(i, icbs(i)) - alv * qg) / (cpd + (cl - cpd) * qnk(i))
     529
     530      ! ori         clw(i,icb(i))=qnk(i)-qg
     531      ! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
     532      clw(i, icbs(i)) = qnk(i) - qg
     533      clw(i, icbs(i)) = max(0.0, clw(i, icbs(i)))
     534
     535      rg = qg / (1. - qnk(i))
     536      ! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
     537      ! convect3: (qg utilise au lieu du vrai mixing ratio rg)
     538      tvp(i, icbs(i)) = tp(i, icbs(i)) * (1. + qg / eps - qnk(i)) !whole thing
     539
     540    END DO
     541
     542    ! ori      do 380 k=minorig,icbsmax2
     543    ! ori       do 370 i=1,len
     544    ! ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
     545    ! ori 370   continue
     546    ! ori 380  continue
     547
     548
     549    ! -- The following is only for convect3:
     550
     551    ! * icbs is the first level above the LCL:
     552    ! if plcl<p(icb), then icbs=icb+1
     553    ! if plcl>p(icb), then icbs=icb
     554
     555    ! * the routine above computes tvp from minorig to icbs (included).
     556
     557    ! * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
     558    ! must be known. This is the case if icbs=icb+1, but not if icbs=icb.
     559
     560    ! * therefore, in the case icbs=icb, we compute tvp at level icb+1
     561    ! (tvp at other levels will be computed in cv3_undilute2.F)
     562
     563    DO i = 1, len
     564      ticb(i) = t(i, icb(i) + 1)
     565      gzicb(i) = gz(i, icb(i) + 1)
     566      qsicb(i) = qs(i, icb(i) + 1)
     567    END DO
     568
     569    DO i = 1, len
     570      tg = ticb(i)
     571      qg = qsicb(i) ! convect3
     572      ! debug         alv=lv0-clmcpv*(ticb(i)-t0)
     573      alv = lv0 - clmcpv * (ticb(i) - 273.15)
     574
     575      ! First iteration.
     576
     577      ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
     578      s = cpd * (1. - qnk(i)) + cl * qnk(i) & ! convect3
     579              + alv * alv * qg / (rrv * ticb(i) * ticb(i)) ! convect3
     580      s = 1. / s
     581      ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
     582      ahg = cpd * tg + (cl - cpd) * qnk(i) * tg + alv * qg + gzicb(i) ! convect3
     583      tg = tg + s * (ah0(i) - ahg)
     584      ! ori          tg=max(tg,35.0)
     585      ! debug          tc=tg-t0
     586      tc = tg - 273.15
     587      denom = 243.5 + tc
     588      denom = max(denom, 1.0) ! convect3
     589      ! ori          IF(tc.ge.0.0)THEN
     590      es = 6.112 * exp(17.67 * tc / denom)
     591      ! ori          else
     592      ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     593      ! ori          endif
     594      ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
     595      qg = eps * es / (p(i, icb(i) + 1) - es * (1. - eps))
     596
     597      ! Second iteration.
     598
     599
     600      ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
     601      ! ori          s=1./s
     602      ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
     603      ahg = cpd * tg + (cl - cpd) * qnk(i) * tg + alv * qg + gzicb(i) ! convect3
     604      tg = tg + s * (ah0(i) - ahg)
     605      ! ori          tg=max(tg,35.0)
     606      ! debug          tc=tg-t0
     607      tc = tg - 273.15
     608      denom = 243.5 + tc
     609      denom = max(denom, 1.0) ! convect3
     610      ! ori          IF(tc.ge.0.0)THEN
     611      es = 6.112 * exp(17.67 * tc / denom)
     612      ! ori          else
     613      ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     614      ! ori          end if
     615      ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
     616      qg = eps * es / (p(i, icb(i) + 1) - es * (1. - eps))
     617
     618      alv = lv0 - clmcpv * (ticb(i) - 273.15)
     619
     620      ! ori c approximation here:
     621      ! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
     622      ! ori     &   -gz(i,icb(i))-alv*qg)/cpd
     623
     624      ! convect3: no approximation:
     625      tp(i, icb(i) + 1) = (ah0(i) - gz(i, icb(i) + 1) - alv * qg) / (cpd + (cl - cpd) * qnk(i))
     626
     627      ! ori         clw(i,icb(i))=qnk(i)-qg
     628      ! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
     629      clw(i, icb(i) + 1) = qnk(i) - qg
     630      clw(i, icb(i) + 1) = max(0.0, clw(i, icb(i) + 1))
     631
     632      rg = qg / (1. - qnk(i))
     633      ! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
     634      ! convect3: (qg utilise au lieu du vrai mixing ratio rg)
     635      tvp(i, icb(i) + 1) = tp(i, icb(i) + 1) * (1. + qg / eps - qnk(i)) !whole thing
     636
     637    END DO
     638
     639  END SUBROUTINE cv30_undilute1
     640
     641  SUBROUTINE cv30_trigger(len, nd, icb, plcl, p, th, tv, tvp, pbase, buoybase, &
     642          iflag, sig, w0)
     643    IMPLICIT NONE
     644
     645    ! -------------------------------------------------------------------
     646    ! --- TRIGGERING
     647
     648    ! - computes the cloud base
     649    ! - triggering (crude in this version)
     650    ! - relaxation of sig and w0 when no convection
     651
     652    ! Caution1: if no convection, we set iflag=4
     653    ! (it used to be 0 in convect3)
     654
     655    ! Caution2: at this stage, tvp (and thus buoy) are know up
     656    ! through icb only!
     657    ! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
     658    ! -------------------------------------------------------------------
     659
     660
     661
     662    ! input:
     663    INTEGER len, nd
     664    INTEGER icb(len)
     665    REAL plcl(len), p(len, nd)
     666    REAL th(len, nd), tv(len, nd), tvp(len, nd)
     667
     668    ! output:
     669    REAL pbase(len), buoybase(len)
     670
     671    ! input AND output:
     672    INTEGER iflag(len)
     673    REAL sig(len, nd), w0(len, nd)
     674
     675    ! local variables:
     676    INTEGER i, k
     677    REAL tvpbase, tvbase, tdif, ath, ath1
     678
     679
     680    ! ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
     681
     682    DO i = 1, len
     683      pbase(i) = plcl(i) + dpbase
     684      tvpbase = tvp(i, icb(i)) * (pbase(i) - p(i, icb(i) + 1)) / &
     685              (p(i, icb(i)) - p(i, icb(i) + 1)) + tvp(i, icb(i) + 1) * (p(i, icb(i)) - pbase(i)) / (&
     686              p(i, icb(i)) - p(i, icb(i) + 1))
     687      tvbase = tv(i, icb(i)) * (pbase(i) - p(i, icb(i) + 1)) / &
     688              (p(i, icb(i)) - p(i, icb(i) + 1)) + tv(i, icb(i) + 1) * (p(i, icb(i)) - pbase(i)) / (p &
     689              (i, icb(i)) - p(i, icb(i) + 1))
     690      buoybase(i) = tvpbase - tvbase
     691    END DO
     692
     693
     694    ! ***   make sure that column is dry adiabatic between the surface  ***
     695    ! ***    and cloud base, and that lifted air is positively buoyant  ***
     696    ! ***                         at cloud base                         ***
     697    ! ***       if not, return to calling program after resetting       ***
     698    ! ***                        sig(i) and w0(i)                       ***
     699
     700
     701    ! oct3      do 200 i=1,len
     702    ! oct3
     703    ! oct3       tdif = buoybase(i)
     704    ! oct3       ath1 = th(i,1)
     705    ! oct3       ath  = th(i,icb(i)-1) - dttrig
     706    ! oct3
     707    ! oct3       if (tdif.lt.dtcrit .OR. ath.gt.ath1) THEN
     708    ! oct3         do 60 k=1,nl
     709    ! oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
     710    ! oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
     711    ! oct3            w0(i,k)  = beta*w0(i,k)
     712    ! oct3   60    continue
     713    ! oct3         iflag(i)=4 ! pour version vectorisee
     714    ! oct3c convect3         iflag(i)=0
     715    ! oct3cccc         RETURN
     716    ! oct3       endif
     717    ! oct3
     718    ! oct3200   continue
     719
     720    ! -- oct3: on reecrit la boucle 200 (pour la vectorisation)
     721
     722    DO k = 1, nl
     723      DO i = 1, len
     724
     725        tdif = buoybase(i)
     726        ath1 = th(i, 1)
     727        ath = th(i, icb(i) - 1) - dttrig
     728
     729        IF (tdif<dtcrit .OR. ath>ath1) THEN
     730          sig(i, k) = beta * sig(i, k) - 2. * alpha * tdif * tdif
     731          sig(i, k) = amax1(sig(i, k), 0.0)
     732          w0(i, k) = beta * w0(i, k)
     733          iflag(i) = 4 ! pour version vectorisee
     734          ! convect3         iflag(i)=0
     735        END IF
     736
     737      END DO
     738    END DO
     739
     740    ! fin oct3 --
     741
     742  END SUBROUTINE cv30_trigger
     743
     744  SUBROUTINE cv30_compress(len, nloc, ncum, nd, ntra, iflag1, nk1, icb1, icbs1, &
     745          plcl1, tnk1, qnk1, gznk1, pbase1, buoybase1, t1, q1, qs1, u1, v1, gz1, &
     746          th1, tra1, h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, sig1, w01, &
     747          iflag, nk, icb, icbs, plcl, tnk, qnk, gznk, pbase, buoybase, t, q, qs, u, &
     748          v, gz, th, tra, h, lv, cpn, p, ph, tv, tp, tvp, clw, sig, w0)
     749    USE print_control_mod, ONLY: lunout
     750    IMPLICIT NONE
     751
     752
     753
     754    ! inputs:
     755    INTEGER len, ncum, nd, ntra, nloc
     756    INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len)
     757    REAL plcl1(len), tnk1(len), qnk1(len), gznk1(len)
     758    REAL pbase1(len), buoybase1(len)
     759    REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
     760    REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
     761    REAL p1(len, nd), ph1(len, nd + 1), tv1(len, nd), tp1(len, nd)
     762    REAL tvp1(len, nd), clw1(len, nd)
     763    REAL th1(len, nd)
     764    REAL sig1(len, nd), w01(len, nd)
     765    REAL tra1(len, nd, ntra)
     766
     767    ! outputs:
     768    ! en fait, on a nloc=len pour l'instant (cf cv_driver)
     769    INTEGER iflag(nloc), nk(nloc), icb(nloc), icbs(nloc)
     770    REAL plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
     771    REAL pbase(nloc), buoybase(nloc)
     772    REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
     773    REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
     774    REAL p(nloc, nd), ph(nloc, nd + 1), tv(nloc, nd), tp(nloc, nd)
     775    REAL tvp(nloc, nd), clw(nloc, nd)
     776    REAL th(nloc, nd)
     777    REAL sig(nloc, nd), w0(nloc, nd)
     778    REAL tra(nloc, nd, ntra)
     779
     780    ! local variables:
     781    INTEGER i, k, nn, j
     782
     783    CHARACTER (LEN = 20) :: modname = 'cv30_compress'
     784    CHARACTER (LEN = 80) :: abort_message
     785
     786    DO k = 1, nl + 1
     787      nn = 0
     788      DO i = 1, len
     789        IF (iflag1(i)==0) THEN
     790          nn = nn + 1
     791          sig(nn, k) = sig1(i, k)
     792          w0(nn, k) = w01(i, k)
     793          t(nn, k) = t1(i, k)
     794          q(nn, k) = q1(i, k)
     795          qs(nn, k) = qs1(i, k)
     796          u(nn, k) = u1(i, k)
     797          v(nn, k) = v1(i, k)
     798          gz(nn, k) = gz1(i, k)
     799          h(nn, k) = h1(i, k)
     800          lv(nn, k) = lv1(i, k)
     801          cpn(nn, k) = cpn1(i, k)
     802          p(nn, k) = p1(i, k)
     803          ph(nn, k) = ph1(i, k)
     804          tv(nn, k) = tv1(i, k)
     805          tp(nn, k) = tp1(i, k)
     806          tvp(nn, k) = tvp1(i, k)
     807          clw(nn, k) = clw1(i, k)
     808          th(nn, k) = th1(i, k)
     809        END IF
     810      END DO
     811    END DO
     812
     813    ! do 121 j=1,ntra
     814    ! do 111 k=1,nd
     815    ! nn=0
     816    ! do 101 i=1,len
     817    ! IF(iflag1(i).EQ.0)THEN
     818    ! nn=nn+1
     819    ! tra(nn,k,j)=tra1(i,k,j)
     820    ! END IF
     821    ! 101  continue
     822    ! 111  continue
     823    ! 121  continue
     824
     825    IF (nn/=ncum) THEN
     826      WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
     827      abort_message = ''
     828      CALL abort_physic(modname, abort_message, 1)
    418829    END IF
    419   END DO !convect3
    420 
    421   DO i = 1, len !convect3
    422     ticb(i) = t(i, icbs(i)) !convect3
    423     gzicb(i) = gz(i, icbs(i)) !convect3
    424     qsicb(i) = qs(i, icbs(i)) !convect3
    425   END DO !convect3
    426 
    427 
    428   ! Re-compute icbsmax (icbsmax2):        !convect3
    429   ! !convect3
    430   icbsmax2 = 2 !convect3
    431   DO i = 1, len !convect3
    432     icbsmax2 = max(icbsmax2, icbs(i)) !convect3
    433   END DO !convect3
    434 
    435   ! initialization outputs:
    436 
    437   DO k = 1, icbsmax2 ! convect3
    438     DO i = 1, len ! convect3
    439       tp(i, k) = 0.0 ! convect3
    440       tvp(i, k) = 0.0 ! convect3
    441       clw(i, k) = 0.0 ! convect3
    442     END DO ! convect3
    443   END DO ! convect3
    444 
    445   ! tp and tvp below cloud base:
    446 
    447   DO k = minorig, icbsmax2 - 1
    448     DO i = 1, len
    449       tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))*cpinv(i)
    450       tvp(i, k) = tp(i, k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
    451     END DO
    452   END DO
    453 
    454   ! ***  Find lifted parcel quantities above cloud base    ***
    455 
    456   DO i = 1, len
    457     tg = ticb(i)
    458     ! ori         qg=qs(i,icb(i))
    459     qg = qsicb(i) ! convect3
    460     ! debug         alv=lv0-clmcpv*(ticb(i)-t0)
    461     alv = lv0 - clmcpv*(ticb(i)-273.15)
    462 
    463     ! First iteration.
    464 
    465     ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
    466     s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
    467       +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
    468     s = 1./s
    469     ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
    470     ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
    471     tg = tg + s*(ah0(i)-ahg)
    472     ! ori          tg=max(tg,35.0)
    473     ! debug          tc=tg-t0
    474     tc = tg - 273.15
    475     denom = 243.5 + tc
    476     denom = max(denom, 1.0) ! convect3
    477     ! ori          if(tc.ge.0.0)then
    478     es = 6.112*exp(17.67*tc/denom)
    479     ! ori          else
    480     ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    481     ! ori          endif
    482     ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
    483     qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
    484 
    485     ! Second iteration.
    486 
    487 
    488     ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
    489     ! ori          s=1./s
    490     ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
    491     ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
    492     tg = tg + s*(ah0(i)-ahg)
    493     ! ori          tg=max(tg,35.0)
    494     ! debug          tc=tg-t0
    495     tc = tg - 273.15
    496     denom = 243.5 + tc
    497     denom = max(denom, 1.0) ! convect3
    498     ! ori          if(tc.ge.0.0)then
    499     es = 6.112*exp(17.67*tc/denom)
    500     ! ori          else
    501     ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    502     ! ori          end if
    503     ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
    504     qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
    505 
    506     alv = lv0 - clmcpv*(ticb(i)-273.15)
    507 
    508     ! ori c approximation here:
    509     ! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
    510     ! ori     &   -gz(i,icb(i))-alv*qg)/cpd
    511 
    512     ! convect3: no approximation:
    513     tp(i, icbs(i)) = (ah0(i)-gz(i,icbs(i))-alv*qg)/(cpd+(cl-cpd)*qnk(i))
    514 
    515     ! ori         clw(i,icb(i))=qnk(i)-qg
    516     ! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
    517     clw(i, icbs(i)) = qnk(i) - qg
    518     clw(i, icbs(i)) = max(0.0, clw(i,icbs(i)))
    519 
    520     rg = qg/(1.-qnk(i))
    521     ! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
    522     ! convect3: (qg utilise au lieu du vrai mixing ratio rg)
    523     tvp(i, icbs(i)) = tp(i, icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
    524 
    525   END DO
    526 
    527   ! ori      do 380 k=minorig,icbsmax2
    528   ! ori       do 370 i=1,len
    529   ! ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
    530   ! ori 370   continue
    531   ! ori 380  continue
    532 
    533 
    534   ! -- The following is only for convect3:
    535 
    536   ! * icbs is the first level above the LCL:
    537   ! if plcl<p(icb), then icbs=icb+1
    538   ! if plcl>p(icb), then icbs=icb
    539 
    540   ! * the routine above computes tvp from minorig to icbs (included).
    541 
    542   ! * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
    543   ! must be known. This is the case if icbs=icb+1, but not if icbs=icb.
    544 
    545   ! * therefore, in the case icbs=icb, we compute tvp at level icb+1
    546   ! (tvp at other levels will be computed in cv3_undilute2.F)
    547 
    548 
    549   DO i = 1, len
    550     ticb(i) = t(i, icb(i)+1)
    551     gzicb(i) = gz(i, icb(i)+1)
    552     qsicb(i) = qs(i, icb(i)+1)
    553   END DO
    554 
    555   DO i = 1, len
    556     tg = ticb(i)
    557     qg = qsicb(i) ! convect3
    558     ! debug         alv=lv0-clmcpv*(ticb(i)-t0)
    559     alv = lv0 - clmcpv*(ticb(i)-273.15)
    560 
    561     ! First iteration.
    562 
    563     ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
    564     s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
    565       +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
    566     s = 1./s
    567     ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
    568     ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
    569     tg = tg + s*(ah0(i)-ahg)
    570     ! ori          tg=max(tg,35.0)
    571     ! debug          tc=tg-t0
    572     tc = tg - 273.15
    573     denom = 243.5 + tc
    574     denom = max(denom, 1.0) ! convect3
    575     ! ori          if(tc.ge.0.0)then
    576     es = 6.112*exp(17.67*tc/denom)
    577     ! ori          else
    578     ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    579     ! ori          endif
    580     ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
    581     qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
    582 
    583     ! Second iteration.
    584 
    585 
    586     ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
    587     ! ori          s=1./s
    588     ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
    589     ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
    590     tg = tg + s*(ah0(i)-ahg)
    591     ! ori          tg=max(tg,35.0)
    592     ! debug          tc=tg-t0
    593     tc = tg - 273.15
    594     denom = 243.5 + tc
    595     denom = max(denom, 1.0) ! convect3
    596     ! ori          if(tc.ge.0.0)then
    597     es = 6.112*exp(17.67*tc/denom)
    598     ! ori          else
    599     ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    600     ! ori          end if
    601     ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
    602     qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
    603 
    604     alv = lv0 - clmcpv*(ticb(i)-273.15)
    605 
    606     ! ori c approximation here:
    607     ! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
    608     ! ori     &   -gz(i,icb(i))-alv*qg)/cpd
    609 
    610     ! convect3: no approximation:
    611     tp(i, icb(i)+1) = (ah0(i)-gz(i,icb(i)+1)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
    612 
    613     ! ori         clw(i,icb(i))=qnk(i)-qg
    614     ! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
    615     clw(i, icb(i)+1) = qnk(i) - qg
    616     clw(i, icb(i)+1) = max(0.0, clw(i,icb(i)+1))
    617 
    618     rg = qg/(1.-qnk(i))
    619     ! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
    620     ! convect3: (qg utilise au lieu du vrai mixing ratio rg)
    621     tvp(i, icb(i)+1) = tp(i, icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
    622 
    623   END DO
    624 
    625   RETURN
    626 END SUBROUTINE cv30_undilute1
    627 
    628 SUBROUTINE cv30_trigger(len, nd, icb, plcl, p, th, tv, tvp, pbase, buoybase, &
    629     iflag, sig, w0)
    630   IMPLICIT NONE
    631 
    632   ! -------------------------------------------------------------------
    633   ! --- TRIGGERING
    634 
    635   ! - computes the cloud base
    636   ! - triggering (crude in this version)
    637   ! - relaxation of sig and w0 when no convection
    638 
    639   ! Caution1: if no convection, we set iflag=4
    640   ! (it used to be 0 in convect3)
    641 
    642   ! Caution2: at this stage, tvp (and thus buoy) are know up
    643   ! through icb only!
    644   ! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
    645   ! -------------------------------------------------------------------
    646 
    647   include "cv30param.h"
    648 
    649   ! input:
    650   INTEGER len, nd
    651   INTEGER icb(len)
    652   REAL plcl(len), p(len, nd)
    653   REAL th(len, nd), tv(len, nd), tvp(len, nd)
    654 
    655   ! output:
    656   REAL pbase(len), buoybase(len)
    657 
    658   ! input AND output:
    659   INTEGER iflag(len)
    660   REAL sig(len, nd), w0(len, nd)
    661 
    662   ! local variables:
    663   INTEGER i, k
    664   REAL tvpbase, tvbase, tdif, ath, ath1
    665 
    666 
    667   ! ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
    668 
    669   DO i = 1, len
    670     pbase(i) = plcl(i) + dpbase
    671     tvpbase = tvp(i, icb(i))*(pbase(i)-p(i,icb(i)+1))/ &
    672       (p(i,icb(i))-p(i,icb(i)+1)) + tvp(i, icb(i)+1)*(p(i,icb(i))-pbase(i))/( &
    673       p(i,icb(i))-p(i,icb(i)+1))
    674     tvbase = tv(i, icb(i))*(pbase(i)-p(i,icb(i)+1))/ &
    675       (p(i,icb(i))-p(i,icb(i)+1)) + tv(i, icb(i)+1)*(p(i,icb(i))-pbase(i))/(p &
    676       (i,icb(i))-p(i,icb(i)+1))
    677     buoybase(i) = tvpbase - tvbase
    678   END DO
    679 
    680 
    681   ! ***   make sure that column is dry adiabatic between the surface  ***
    682   ! ***    and cloud base, and that lifted air is positively buoyant  ***
    683   ! ***                         at cloud base                         ***
    684   ! ***       if not, return to calling program after resetting       ***
    685   ! ***                        sig(i) and w0(i)                       ***
    686 
    687 
    688   ! oct3      do 200 i=1,len
    689   ! oct3
    690   ! oct3       tdif = buoybase(i)
    691   ! oct3       ath1 = th(i,1)
    692   ! oct3       ath  = th(i,icb(i)-1) - dttrig
    693   ! oct3
    694   ! oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
    695   ! oct3         do 60 k=1,nl
    696   ! oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
    697   ! oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
    698   ! oct3            w0(i,k)  = beta*w0(i,k)
    699   ! oct3   60    continue
    700   ! oct3         iflag(i)=4 ! pour version vectorisee
    701   ! oct3c convect3         iflag(i)=0
    702   ! oct3cccc         return
    703   ! oct3       endif
    704   ! oct3
    705   ! oct3200   continue
    706 
    707   ! -- oct3: on reecrit la boucle 200 (pour la vectorisation)
    708 
    709   DO k = 1, nl
    710     DO i = 1, len
    711 
    712       tdif = buoybase(i)
    713       ath1 = th(i, 1)
    714       ath = th(i, icb(i)-1) - dttrig
    715 
    716       IF (tdif<dtcrit .OR. ath>ath1) THEN
    717         sig(i, k) = beta*sig(i, k) - 2.*alpha*tdif*tdif
    718         sig(i, k) = amax1(sig(i,k), 0.0)
    719         w0(i, k) = beta*w0(i, k)
    720         iflag(i) = 4 ! pour version vectorisee
    721         ! convect3         iflag(i)=0
    722       END IF
    723 
    724     END DO
    725   END DO
    726 
    727   ! fin oct3 --
    728 
    729   RETURN
    730 END SUBROUTINE cv30_trigger
    731 
    732 SUBROUTINE cv30_compress(len, nloc, ncum, nd, ntra, iflag1, nk1, icb1, icbs1, &
    733     plcl1, tnk1, qnk1, gznk1, pbase1, buoybase1, t1, q1, qs1, u1, v1, gz1, &
    734     th1, tra1, h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, sig1, w01, &
    735     iflag, nk, icb, icbs, plcl, tnk, qnk, gznk, pbase, buoybase, t, q, qs, u, &
    736     v, gz, th, tra, h, lv, cpn, p, ph, tv, tp, tvp, clw, sig, w0)
    737   USE print_control_mod, ONLY: lunout
    738   IMPLICIT NONE
    739 
    740   include "cv30param.h"
    741 
    742   ! inputs:
    743   INTEGER len, ncum, nd, ntra, nloc
    744   INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len)
    745   REAL plcl1(len), tnk1(len), qnk1(len), gznk1(len)
    746   REAL pbase1(len), buoybase1(len)
    747   REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
    748   REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
    749   REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
    750   REAL tvp1(len, nd), clw1(len, nd)
    751   REAL th1(len, nd)
    752   REAL sig1(len, nd), w01(len, nd)
    753   REAL tra1(len, nd, ntra)
    754 
    755   ! outputs:
    756   ! en fait, on a nloc=len pour l'instant (cf cv_driver)
    757   INTEGER iflag(nloc), nk(nloc), icb(nloc), icbs(nloc)
    758   REAL plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
    759   REAL pbase(nloc), buoybase(nloc)
    760   REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
    761   REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
    762   REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
    763   REAL tvp(nloc, nd), clw(nloc, nd)
    764   REAL th(nloc, nd)
    765   REAL sig(nloc, nd), w0(nloc, nd)
    766   REAL tra(nloc, nd, ntra)
    767 
    768   ! local variables:
    769   INTEGER i, k, nn, j
    770 
    771   CHARACTER (LEN=20) :: modname = 'cv30_compress'
    772   CHARACTER (LEN=80) :: abort_message
    773 
    774 
    775   DO k = 1, nl + 1
     830
    776831    nn = 0
    777832    DO i = 1, len
    778833      IF (iflag1(i)==0) THEN
    779834        nn = nn + 1
    780         sig(nn, k) = sig1(i, k)
    781         w0(nn, k) = w01(i, k)
    782         t(nn, k) = t1(i, k)
    783         q(nn, k) = q1(i, k)
    784         qs(nn, k) = qs1(i, k)
    785         u(nn, k) = u1(i, k)
    786         v(nn, k) = v1(i, k)
    787         gz(nn, k) = gz1(i, k)
    788         h(nn, k) = h1(i, k)
    789         lv(nn, k) = lv1(i, k)
    790         cpn(nn, k) = cpn1(i, k)
    791         p(nn, k) = p1(i, k)
    792         ph(nn, k) = ph1(i, k)
    793         tv(nn, k) = tv1(i, k)
    794         tp(nn, k) = tp1(i, k)
    795         tvp(nn, k) = tvp1(i, k)
    796         clw(nn, k) = clw1(i, k)
    797         th(nn, k) = th1(i, k)
     835        pbase(nn) = pbase1(i)
     836        buoybase(nn) = buoybase1(i)
     837        plcl(nn) = plcl1(i)
     838        tnk(nn) = tnk1(i)
     839        qnk(nn) = qnk1(i)
     840        gznk(nn) = gznk1(i)
     841        nk(nn) = nk1(i)
     842        icb(nn) = icb1(i)
     843        icbs(nn) = icbs1(i)
     844        iflag(nn) = iflag1(i)
    798845      END IF
    799846    END DO
    800   END DO
    801 
    802   ! do 121 j=1,ntra
    803   ! do 111 k=1,nd
    804   ! nn=0
    805   ! do 101 i=1,len
    806   ! if(iflag1(i).eq.0)then
    807   ! nn=nn+1
    808   ! tra(nn,k,j)=tra1(i,k,j)
    809   ! endif
    810   ! 101  continue
    811   ! 111  continue
    812   ! 121  continue
    813 
    814   IF (nn/=ncum) THEN
    815     WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
    816     abort_message = ''
    817     CALL abort_physic(modname, abort_message, 1)
    818   END IF
    819 
    820   nn = 0
    821   DO i = 1, len
    822     IF (iflag1(i)==0) THEN
    823       nn = nn + 1
    824       pbase(nn) = pbase1(i)
    825       buoybase(nn) = buoybase1(i)
    826       plcl(nn) = plcl1(i)
    827       tnk(nn) = tnk1(i)
    828       qnk(nn) = qnk1(i)
    829       gznk(nn) = gznk1(i)
    830       nk(nn) = nk1(i)
    831       icb(nn) = icb1(i)
    832       icbs(nn) = icbs1(i)
    833       iflag(nn) = iflag1(i)
    834     END IF
    835   END DO
    836 
    837   RETURN
    838 END SUBROUTINE cv30_compress
    839 
    840 SUBROUTINE cv30_undilute2(nloc, ncum, nd, icb, icbs, nk, tnk, qnk, gznk, t, &
    841     q, qs, gz, p, h, tv, lv, pbase, buoybase, plcl, inb, tp, tvp, clw, hp, &
    842     ep, sigp, buoy)
     847
     848  END SUBROUTINE cv30_compress
     849
     850  SUBROUTINE cv30_undilute2(nloc, ncum, nd, icb, icbs, nk, tnk, qnk, gznk, t, &
     851          q, qs, gz, p, h, tv, lv, pbase, buoybase, plcl, inb, tp, tvp, clw, hp, &
     852          ep, sigp, buoy)
    843853    ! epmax_cape: ajout arguments
    844   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    845           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    846   IMPLICIT NONE
    847 
    848   ! ---------------------------------------------------------------------
    849   ! Purpose:
    850   ! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
    851   ! &
    852   ! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
    853   ! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
    854   ! &
    855   ! FIND THE LEVEL OF NEUTRAL BUOYANCY
    856 
    857   ! Main differences convect3/convect4:
    858   ! - icbs (input) is the first level above LCL (may differ from icb)
    859   ! - many minor differences in the iterations
    860   ! - condensed water not removed from tvp in convect3
    861   ! - vertical profile of buoyancy computed here (use of buoybase)
    862   ! - the determination of inb is different
    863   ! - no inb1, only inb in output
    864   ! ---------------------------------------------------------------------
    865 
    866   include "cv30param.h"
    867   include "conema3.h"
    868 
    869   ! inputs:
    870   INTEGER ncum, nd, nloc
    871   INTEGER icb(nloc), icbs(nloc), nk(nloc)
    872   REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
    873   REAL p(nloc, nd)
    874   REAL tnk(nloc), qnk(nloc), gznk(nloc)
    875   REAL lv(nloc, nd), tv(nloc, nd), h(nloc, nd)
    876   REAL pbase(nloc), buoybase(nloc), plcl(nloc)
    877 
    878   ! outputs:
    879   INTEGER inb(nloc)
    880   REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
    881   REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
    882   REAL buoy(nloc, nd)
    883 
    884   ! local variables:
    885   INTEGER i, k
    886   REAL tg, qg, ahg, alv, s, tc, es, denom, rg, tca, elacrit
    887   REAL by, defrac, pden
    888   REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
    889   LOGICAL lcape(nloc)
    890 
    891   ! =====================================================================
    892   ! --- SOME INITIALIZATIONS
    893   ! =====================================================================
    894 
    895   DO k = 1, nl
    896     DO i = 1, ncum
    897       ep(i, k) = 0.0
    898       sigp(i, k) = spfac
    899     END DO
    900   END DO
    901 
    902   ! =====================================================================
    903   ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
    904   ! =====================================================================
    905 
    906   ! ---       The procedure is to solve the equation.
    907   ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
    908 
    909   ! ***  Calculate certain parcel quantities, including static energy   ***
    910 
    911 
    912   DO i = 1, ncum
    913     ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) & ! debug     &
    914                                                   ! +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
    915       +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i)
    916   END DO
    917 
    918 
    919   ! ***  Find lifted parcel quantities above cloud base    ***
    920 
    921 
    922   DO k = minorig + 1, nl
    923     DO i = 1, ncum
    924       ! ori         if(k.ge.(icb(i)+1))then
    925       IF (k>=(icbs(i)+1)) THEN ! convect3
    926         tg = t(i, k)
    927         qg = qs(i, k)
    928         ! debug       alv=lv0-clmcpv*(t(i,k)-t0)
    929         alv = lv0 - clmcpv*(t(i,k)-273.15)
    930 
    931         ! First iteration.
    932 
    933         ! ori          s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
    934         s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
    935           +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
    936         s = 1./s
    937         ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
    938         ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
    939         tg = tg + s*(ah0(i)-ahg)
    940         ! ori          tg=max(tg,35.0)
    941         ! debug        tc=tg-t0
    942         tc = tg - 273.15
    943         denom = 243.5 + tc
    944         denom = max(denom, 1.0) ! convect3
    945         ! ori          if(tc.ge.0.0)then
    946         es = 6.112*exp(17.67*tc/denom)
    947         ! ori          else
    948         ! ori                   es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    949         ! ori          endif
    950         qg = eps*es/(p(i,k)-es*(1.-eps))
    951 
    952         ! Second iteration.
    953 
    954         ! ori          s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
    955         ! ori          s=1./s
    956         ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
    957         ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
    958         tg = tg + s*(ah0(i)-ahg)
    959         ! ori          tg=max(tg,35.0)
    960         ! debug        tc=tg-t0
    961         tc = tg - 273.15
    962         denom = 243.5 + tc
    963         denom = max(denom, 1.0) ! convect3
    964         ! ori          if(tc.ge.0.0)then
    965         es = 6.112*exp(17.67*tc/denom)
    966         ! ori          else
    967         ! ori                   es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    968         ! ori          endif
    969         qg = eps*es/(p(i,k)-es*(1.-eps))
    970 
    971         ! debug        alv=lv0-clmcpv*(t(i,k)-t0)
    972         alv = lv0 - clmcpv*(t(i,k)-273.15)
    973         ! print*,'cpd dans convect2 ',cpd
    974         ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
    975         ! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
    976 
    977         ! ori c approximation here:
    978         ! ori
    979         ! tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
    980 
    981         ! convect3: no approximation:
    982         tp(i, k) = (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
    983 
    984         clw(i, k) = qnk(i) - qg
    985         clw(i, k) = max(0.0, clw(i,k))
    986         rg = qg/(1.-qnk(i))
    987         ! ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
    988         ! convect3: (qg utilise au lieu du vrai mixing ratio rg):
    989         tvp(i, k) = tp(i, k)*(1.+qg/eps-qnk(i)) ! whole thing
    990       END IF
    991     END DO
    992   END DO
    993 
    994   ! =====================================================================
    995   ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
    996   ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
    997   ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
    998   ! =====================================================================
    999 
    1000   ! ori      do 320 k=minorig+1,nl
    1001   DO k = 1, nl ! convect3
    1002     DO i = 1, ncum
    1003       pden = ptcrit - pbcrit
    1004       ep(i, k) = (plcl(i)-p(i,k)-pbcrit)/pden*epmax
    1005       ep(i, k) = amax1(ep(i,k), 0.0)
    1006       ep(i, k) = amin1(ep(i,k), epmax)
    1007       sigp(i, k) = spfac
    1008       ! ori          if(k.ge.(nk(i)+1))then
    1009       ! ori            tca=tp(i,k)-t0
    1010       ! ori            if(tca.ge.0.0)then
    1011       ! ori              elacrit=elcrit
    1012       ! ori            else
    1013       ! ori              elacrit=elcrit*(1.0-tca/tlcrit)
    1014       ! ori            endif
    1015       ! ori            elacrit=max(elacrit,0.0)
    1016       ! ori            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
    1017       ! ori            ep(i,k)=max(ep(i,k),0.0 )
    1018       ! ori            ep(i,k)=min(ep(i,k),1.0 )
    1019       ! ori            sigp(i,k)=sigs
    1020       ! ori          endif
    1021     END DO
    1022   END DO
    1023 
    1024   ! =====================================================================
    1025   ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
    1026   ! --- VIRTUAL TEMPERATURE
    1027   ! =====================================================================
    1028 
    1029   ! dans convect3, tvp est calcule en une seule fois, et sans retirer
    1030   ! l'eau condensee (~> reversible CAPE)
    1031 
    1032   ! ori      do 340 k=minorig+1,nl
    1033   ! ori        do 330 i=1,ncum
    1034   ! ori        if(k.ge.(icb(i)+1))then
    1035   ! ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
    1036   ! oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
    1037   ! oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
    1038   ! ori        endif
    1039   ! ori 330    continue
    1040   ! ori 340  continue
    1041 
    1042   ! ori      do 350 i=1,ncum
    1043   ! ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
    1044   ! ori 350  continue
    1045 
    1046   DO i = 1, ncum ! convect3
    1047     tp(i, nlp) = tp(i, nl) ! convect3
    1048   END DO ! convect3
    1049 
    1050   ! =====================================================================
    1051   ! --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
    1052   ! =====================================================================
    1053 
    1054   ! -- this is for convect3 only:
    1055 
    1056   ! first estimate of buoyancy:
    1057 
    1058   DO i = 1, ncum
    1059     DO k = 1, nl
    1060       buoy(i, k) = tvp(i, k) - tv(i, k)
    1061     END DO
    1062   END DO
    1063 
    1064   ! set buoyancy=buoybase for all levels below base
    1065   ! for safety, set buoy(icb)=buoybase
    1066 
    1067   DO i = 1, ncum
    1068     DO k = 1, nl
    1069       IF ((k>=icb(i)) .AND. (k<=nl) .AND. (p(i,k)>=pbase(i))) THEN
    1070         buoy(i, k) = buoybase(i)
    1071       END IF
    1072     END DO
    1073     ! IM cf. CRio/JYG 270807   buoy(icb(i),k)=buoybase(i)
    1074     buoy(i, icb(i)) = buoybase(i)
    1075   END DO
    1076 
    1077   ! -- end convect3
    1078 
    1079   ! =====================================================================
    1080   ! --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
    1081   ! --- LEVEL OF NEUTRAL BUOYANCY
    1082   ! =====================================================================
    1083 
    1084   ! -- this is for convect3 only:
    1085 
    1086   DO i = 1, ncum
    1087     inb(i) = nl - 1
    1088   END DO
    1089 
    1090   DO i = 1, ncum
    1091     DO k = 1, nl - 1
    1092       IF ((k>=icb(i)) .AND. (buoy(i,k)<dtovsh)) THEN
    1093         inb(i) = min(inb(i), k)
    1094       END IF
    1095     END DO
    1096   END DO
    1097 
    1098   ! -- end convect3
    1099 
    1100   ! ori      do 510 i=1,ncum
    1101   ! ori        cape(i)=0.0
    1102   ! ori        capem(i)=0.0
    1103   ! ori        inb(i)=icb(i)+1
    1104   ! ori        inb1(i)=inb(i)
    1105   ! ori 510  continue
    1106 
    1107   ! Originial Code
    1108 
    1109   ! do 530 k=minorig+1,nl-1
    1110   ! do 520 i=1,ncum
    1111   ! if(k.ge.(icb(i)+1))then
    1112   ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
    1113   ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
    1114   ! cape(i)=cape(i)+by
    1115   ! if(by.ge.0.0)inb1(i)=k+1
    1116   ! if(cape(i).gt.0.0)then
    1117   ! inb(i)=k+1
    1118   ! capem(i)=cape(i)
    1119   ! endif
    1120   ! endif
    1121   ! 520    continue
    1122   ! 530  continue
    1123   ! do 540 i=1,ncum
    1124   ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
    1125   ! cape(i)=capem(i)+byp
    1126   ! defrac=capem(i)-cape(i)
    1127   ! defrac=max(defrac,0.001)
    1128   ! frac(i)=-cape(i)/defrac
    1129   ! frac(i)=min(frac(i),1.0)
    1130   ! frac(i)=max(frac(i),0.0)
    1131   ! 540   continue
    1132 
    1133   ! K Emanuel fix
    1134 
    1135   ! call zilch(byp,ncum)
    1136   ! do 530 k=minorig+1,nl-1
    1137   ! do 520 i=1,ncum
    1138   ! if(k.ge.(icb(i)+1))then
    1139   ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
    1140   ! cape(i)=cape(i)+by
    1141   ! if(by.ge.0.0)inb1(i)=k+1
    1142   ! if(cape(i).gt.0.0)then
    1143   ! inb(i)=k+1
    1144   ! capem(i)=cape(i)
    1145   ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
    1146   ! endif
    1147   ! endif
    1148   ! 520    continue
    1149   ! 530  continue
    1150   ! do 540 i=1,ncum
    1151   ! inb(i)=max(inb(i),inb1(i))
    1152   ! cape(i)=capem(i)+byp(i)
    1153   ! defrac=capem(i)-cape(i)
    1154   ! defrac=max(defrac,0.001)
    1155   ! frac(i)=-cape(i)/defrac
    1156   ! frac(i)=min(frac(i),1.0)
    1157   ! frac(i)=max(frac(i),0.0)
    1158   ! 540   continue
    1159 
    1160   ! J Teixeira fix
    1161 
    1162   ! ori      call zilch(byp,ncum)
    1163   ! ori      do 515 i=1,ncum
    1164   ! ori        lcape(i)=.true.
    1165   ! ori 515  continue
    1166   ! ori      do 530 k=minorig+1,nl-1
    1167   ! ori        do 520 i=1,ncum
    1168   ! ori          if(cape(i).lt.0.0)lcape(i)=.false.
    1169   ! ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
    1170   ! ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
    1171   ! ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
    1172   ! ori            cape(i)=cape(i)+by
    1173   ! ori            if(by.ge.0.0)inb1(i)=k+1
    1174   ! ori            if(cape(i).gt.0.0)then
    1175   ! ori              inb(i)=k+1
    1176   ! ori              capem(i)=cape(i)
    1177   ! ori            endif
    1178   ! ori          endif
    1179   ! ori 520    continue
    1180   ! ori 530  continue
    1181   ! ori      do 540 i=1,ncum
    1182   ! ori          cape(i)=capem(i)+byp(i)
    1183   ! ori          defrac=capem(i)-cape(i)
    1184   ! ori          defrac=max(defrac,0.001)
    1185   ! ori          frac(i)=-cape(i)/defrac
    1186   ! ori          frac(i)=min(frac(i),1.0)
    1187   ! ori          frac(i)=max(frac(i),0.0)
    1188   ! ori 540  continue
    1189 
    1190   ! =====================================================================
    1191   ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
    1192   ! =====================================================================
    1193 
    1194   ! ym      do i=1,ncum*nlp
    1195   ! ym       hp(i,1)=h(i,1)
    1196   ! ym      enddo
    1197 
    1198   DO k = 1, nlp
    1199     DO i = 1, ncum
    1200       hp(i, k) = h(i, k)
    1201     END DO
    1202   END DO
    1203 
    1204   DO k = minorig + 1, nl
    1205     DO i = 1, ncum
    1206       IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
    1207         hp(i, k) = h(i, nk(i)) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k &
    1208           )
    1209       END IF
    1210     END DO
    1211   END DO
    1212 
    1213   RETURN
    1214 END SUBROUTINE cv30_undilute2
    1215 
    1216 SUBROUTINE cv30_closure(nloc, ncum, nd, icb, inb, pbase, p, ph, tv, buoy, &
    1217     sig, w0, cape, m)
    1218   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    1219           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    1220   IMPLICIT NONE
    1221 
    1222   ! ===================================================================
    1223   ! ---  CLOSURE OF CONVECT3
    1224 
    1225   ! vectorization: S. Bony
    1226   ! ===================================================================
    1227 
    1228   include "cv30param.h"
    1229 
    1230   ! input:
    1231   INTEGER ncum, nd, nloc
    1232   INTEGER icb(nloc), inb(nloc)
    1233   REAL pbase(nloc)
    1234   REAL p(nloc, nd), ph(nloc, nd+1)
    1235   REAL tv(nloc, nd), buoy(nloc, nd)
    1236 
    1237   ! input/output:
    1238   REAL sig(nloc, nd), w0(nloc, nd)
    1239 
    1240   ! output:
    1241   REAL cape(nloc)
    1242   REAL m(nloc, nd)
    1243 
    1244   ! local variables:
    1245   INTEGER i, j, k, icbmax
    1246   REAL deltap, fac, w, amu
    1247   REAL dtmin(nloc, nd), sigold(nloc, nd)
    1248 
    1249   ! -------------------------------------------------------
    1250   ! -- Initialization
    1251   ! -------------------------------------------------------
    1252 
    1253   DO k = 1, nl
    1254     DO i = 1, ncum
    1255       m(i, k) = 0.0
    1256     END DO
    1257   END DO
    1258 
    1259   ! -------------------------------------------------------
    1260   ! -- Reset sig(i) and w0(i) for i>inb and i<icb
    1261   ! -------------------------------------------------------
    1262 
    1263   ! update sig and w0 above LNB:
    1264 
    1265   DO k = 1, nl - 1
    1266     DO i = 1, ncum
    1267       IF ((inb(i)<(nl-1)) .AND. (k>=(inb(i)+1))) THEN
    1268         sig(i, k) = beta*sig(i, k) + 2.*alpha*buoy(i, inb(i))*abs(buoy(i,inb( &
    1269           i)))
    1270         sig(i, k) = amax1(sig(i,k), 0.0)
    1271         w0(i, k) = beta*w0(i, k)
    1272       END IF
    1273     END DO
    1274   END DO
    1275 
    1276   ! compute icbmax:
    1277 
    1278   icbmax = 2
    1279   DO i = 1, ncum
    1280     icbmax = max(icbmax, icb(i))
    1281   END DO
    1282 
    1283   ! update sig and w0 below cloud base:
    1284 
    1285   DO k = 1, icbmax
    1286     DO i = 1, ncum
    1287       IF (k<=icb(i)) THEN
    1288         sig(i, k) = beta*sig(i, k) - 2.*alpha*buoy(i, icb(i))*buoy(i, icb(i))
    1289         sig(i, k) = amax1(sig(i,k), 0.0)
    1290         w0(i, k) = beta*w0(i, k)
    1291       END IF
    1292     END DO
    1293   END DO
    1294 
    1295   ! !      if(inb.lt.(nl-1))then
    1296   ! !         do 85 i=inb+1,nl-1
    1297   ! !            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
    1298   ! !     1              abs(buoy(inb))
    1299   ! !            sig(i)=amax1(sig(i),0.0)
    1300   ! !            w0(i)=beta*w0(i)
    1301   ! !   85    continue
    1302   ! !      end if
    1303 
    1304   ! !      do 87 i=1,icb
    1305   ! !         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
    1306   ! !         sig(i)=amax1(sig(i),0.0)
    1307   ! !         w0(i)=beta*w0(i)
    1308   ! !   87 continue
    1309 
    1310   ! -------------------------------------------------------------
    1311   ! -- Reset fractional areas of updrafts and w0 at initial time
    1312   ! -- and after 10 time steps of no convection
    1313   ! -------------------------------------------------------------
    1314 
    1315   DO k = 1, nl - 1
    1316     DO i = 1, ncum
    1317       IF (sig(i,nd)<1.5 .OR. sig(i,nd)>12.0) THEN
    1318         sig(i, k) = 0.0
    1319         w0(i, k) = 0.0
    1320       END IF
    1321     END DO
    1322   END DO
    1323 
    1324   ! -------------------------------------------------------------
    1325   ! -- Calculate convective available potential energy (cape),
    1326   ! -- vertical velocity (w), fractional area covered by
    1327   ! -- undilute updraft (sig), and updraft mass flux (m)
    1328   ! -------------------------------------------------------------
    1329 
    1330   DO i = 1, ncum
    1331     cape(i) = 0.0
    1332   END DO
    1333 
    1334   ! compute dtmin (minimum buoyancy between ICB and given level k):
    1335 
    1336   DO i = 1, ncum
    1337     DO k = 1, nl
    1338       dtmin(i, k) = 100.0
    1339     END DO
    1340   END DO
    1341 
    1342   DO i = 1, ncum
    1343     DO k = 1, nl
    1344       DO j = minorig, nl
    1345         IF ((k>=(icb(i)+1)) .AND. (k<=inb(i)) .AND. (j>=icb(i)) .AND. (j<=(k- &
    1346             1))) THEN
    1347           dtmin(i, k) = amin1(dtmin(i,k), buoy(i,j))
    1348         END IF
    1349       END DO
    1350     END DO
    1351   END DO
    1352 
    1353   ! the interval on which cape is computed starts at pbase :
    1354   DO k = 1, nl
    1355     DO i = 1, ncum
    1356 
    1357       IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
    1358 
    1359         deltap = min(pbase(i), ph(i,k-1)) - min(pbase(i), ph(i,k))
    1360         cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1)
    1361         cape(i) = amax1(0.0, cape(i))
    1362         sigold(i, k) = sig(i, k)
    1363 
    1364         ! dtmin(i,k)=100.0
    1365         ! do 97 j=icb(i),k-1 ! mauvaise vectorisation
    1366         ! dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
    1367         ! 97     continue
    1368 
    1369         sig(i, k) = beta*sig(i, k) + alpha*dtmin(i, k)*abs(dtmin(i,k))
    1370         sig(i, k) = amax1(sig(i,k), 0.0)
    1371         sig(i, k) = amin1(sig(i,k), 0.01)
    1372         fac = amin1(((dtcrit-dtmin(i,k))/dtcrit), 1.0)
    1373         w = (1.-beta)*fac*sqrt(cape(i)) + beta*w0(i, k)
    1374         amu = 0.5*(sig(i,k)+sigold(i,k))*w
    1375         m(i, k) = amu*0.007*p(i, k)*(ph(i,k)-ph(i,k+1))/tv(i, k)
    1376         w0(i, k) = w
    1377       END IF
    1378 
    1379     END DO
    1380   END DO
    1381 
    1382   DO i = 1, ncum
    1383     w0(i, icb(i)) = 0.5*w0(i, icb(i)+1)
    1384     m(i, icb(i)) = 0.5*m(i, icb(i)+1)*(ph(i,icb(i))-ph(i,icb(i)+1))/ &
    1385       (ph(i,icb(i)+1)-ph(i,icb(i)+2))
    1386     sig(i, icb(i)) = sig(i, icb(i)+1)
    1387     sig(i, icb(i)-1) = sig(i, icb(i))
    1388   END DO
    1389 
    1390 
    1391   ! !      cape=0.0
    1392   ! !      do 98 i=icb+1,inb
    1393   ! !         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
    1394   ! !         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
    1395   ! !         dcape=rrd*buoy(i-1)*deltap/p(i-1)
    1396   ! !         dlnp=deltap/p(i-1)
    1397   ! !         cape=amax1(0.0,cape)
    1398   ! !         sigold=sig(i)
    1399 
    1400   ! !         dtmin=100.0
    1401   ! !         do 97 j=icb,i-1
    1402   ! !            dtmin=amin1(dtmin,buoy(j))
    1403   ! !   97    continue
    1404 
    1405   ! !         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
    1406   ! !         sig(i)=amax1(sig(i),0.0)
    1407   ! !         sig(i)=amin1(sig(i),0.01)
    1408   ! !         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
    1409   ! !         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
    1410   ! !         amu=0.5*(sig(i)+sigold)*w
    1411   ! !         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
    1412   ! !         w0(i)=w
    1413   ! !   98 continue
    1414   ! !      w0(icb)=0.5*w0(icb+1)
    1415   ! !      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
    1416   ! !      sig(icb)=sig(icb+1)
    1417   ! !      sig(icb-1)=sig(icb)
    1418 
    1419   RETURN
    1420 END SUBROUTINE cv30_closure
    1421 
    1422 SUBROUTINE cv30_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, ph, t, rr, rs, &
    1423     u, v, tra, h, lv, qnk, hp, tv, tvp, ep, clw, m, sig, ment, qent, uent, &
    1424     vent, sij, elij, ments, qents, traent)
    1425   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    1426           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    1427   IMPLICIT NONE
    1428 
    1429   ! ---------------------------------------------------------------------
    1430   ! a faire:
    1431   ! - changer rr(il,1) -> qnk(il)
    1432   ! - vectorisation de la partie normalisation des flux (do 789...)
    1433   ! ---------------------------------------------------------------------
    1434 
    1435   include "cv30param.h"
    1436 
    1437   ! inputs:
    1438   INTEGER ncum, nd, na, ntra, nloc
    1439   INTEGER icb(nloc), inb(nloc), nk(nloc)
    1440   REAL sig(nloc, nd)
    1441   REAL qnk(nloc)
    1442   REAL ph(nloc, nd+1)
    1443   REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
    1444   REAL u(nloc, nd), v(nloc, nd)
    1445   REAL tra(nloc, nd, ntra) ! input of convect3
    1446   REAL lv(nloc, na), h(nloc, na), hp(nloc, na)
    1447   REAL tv(nloc, na), tvp(nloc, na), ep(nloc, na), clw(nloc, na)
    1448   REAL m(nloc, na) ! input of convect3
    1449 
    1450   ! outputs:
    1451   REAL ment(nloc, na, na), qent(nloc, na, na)
    1452   REAL uent(nloc, na, na), vent(nloc, na, na)
    1453   REAL sij(nloc, na, na), elij(nloc, na, na)
    1454   REAL traent(nloc, nd, nd, ntra)
    1455   REAL ments(nloc, nd, nd), qents(nloc, nd, nd)
    1456   REAL sigij(nloc, nd, nd)
    1457 
    1458   ! local variables:
    1459   INTEGER i, j, k, il, im, jm
    1460   INTEGER num1, num2
    1461   INTEGER nent(nloc, na)
    1462   REAL rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
    1463   REAL alt, smid, sjmin, sjmax, delp, delm
    1464   REAL asij(nloc), smax(nloc), scrit(nloc)
    1465   REAL asum(nloc, nd), bsum(nloc, nd), csum(nloc, nd)
    1466   REAL wgh
    1467   REAL zm(nloc, na)
    1468   LOGICAL lwork(nloc)
    1469 
    1470   ! =====================================================================
    1471   ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
    1472   ! =====================================================================
    1473 
    1474   ! ori        do 360 i=1,ncum*nlp
    1475   DO j = 1, nl
    1476     DO i = 1, ncum
    1477       nent(i, j) = 0
    1478       ! in convect3, m is computed in cv3_closure
    1479       ! ori          m(i,1)=0.0
    1480     END DO
    1481   END DO
    1482 
    1483   ! ori      do 400 k=1,nlp
    1484   ! ori       do 390 j=1,nlp
    1485   DO j = 1, nl
     854    USE conema3_mod_h
     855    USE cvthermo_mod_h
     856
     857    IMPLICIT NONE
     858
     859    ! ---------------------------------------------------------------------
     860    ! Purpose:
     861    ! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
     862    ! &
     863    ! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
     864    ! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
     865    ! &
     866    ! FIND THE LEVEL OF NEUTRAL BUOYANCY
     867
     868    ! Main differences convect3/convect4:
     869    ! - icbs (input) is the first level above LCL (may differ from icb)
     870    ! - many minor differences in the iterations
     871    ! - condensed water not removed from tvp in convect3
     872    ! - vertical profile of buoyancy computed here (use of buoybase)
     873    ! - the determination of inb is different
     874    ! - no inb1, ONLY inb in output
     875    ! ---------------------------------------------------------------------
     876
     877
     878
     879    ! inputs:
     880    INTEGER ncum, nd, nloc
     881    INTEGER icb(nloc), icbs(nloc), nk(nloc)
     882    REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
     883    REAL p(nloc, nd)
     884    REAL tnk(nloc), qnk(nloc), gznk(nloc)
     885    REAL lv(nloc, nd), tv(nloc, nd), h(nloc, nd)
     886    REAL pbase(nloc), buoybase(nloc), plcl(nloc)
     887
     888    ! outputs:
     889    INTEGER inb(nloc)
     890    REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
     891    REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
     892    REAL buoy(nloc, nd)
     893
     894    ! local variables:
     895    INTEGER i, k
     896    REAL tg, qg, ahg, alv, s, tc, es, denom, rg, tca, elacrit
     897    REAL by, defrac, pden
     898    REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
     899    LOGICAL lcape(nloc)
     900
     901    ! =====================================================================
     902    ! --- SOME INITIALIZATIONS
     903    ! =====================================================================
     904
    1486905    DO k = 1, nl
    1487906      DO i = 1, ncum
    1488         qent(i, k, j) = rr(i, j)
    1489         uent(i, k, j) = u(i, j)
    1490         vent(i, k, j) = v(i, j)
    1491         elij(i, k, j) = 0.0
    1492         ! ym            ment(i,k,j)=0.0
    1493         ! ym            sij(i,k,j)=0.0
    1494       END DO
    1495     END DO
    1496   END DO
    1497 
    1498   ! ym
    1499   ment(1:ncum, 1:nd, 1:nd) = 0.0
    1500   sij(1:ncum, 1:nd, 1:nd) = 0.0
    1501 
    1502   ! do k=1,ntra
    1503   ! do j=1,nd  ! instead nlp
    1504   ! do i=1,nd ! instead nlp
    1505   ! do il=1,ncum
    1506   ! traent(il,i,j,k)=tra(il,j,k)
    1507   ! enddo
    1508   ! enddo
    1509   ! enddo
    1510   ! enddo
    1511   zm(:, :) = 0.
    1512 
    1513   ! =====================================================================
    1514   ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
    1515   ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
    1516   ! --- FRACTION (sij)
    1517   ! =====================================================================
    1518 
    1519   DO i = minorig + 1, nl
    1520 
    1521     DO j = minorig, nl
    1522       DO il = 1, ncum
    1523         IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)- &
    1524             1)) .AND. (j<=inb(il))) THEN
    1525 
    1526           rti = rr(il, 1) - ep(il, i)*clw(il, i)
    1527           bf2 = 1. + lv(il, j)*lv(il, j)*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
    1528           anum = h(il, j) - hp(il, i) + (cpv-cpd)*t(il, j)*(rti-rr(il,j))
    1529           denom = h(il, i) - hp(il, i) + (cpd-cpv)*(rr(il,i)-rti)*t(il, j)
    1530           dei = denom
    1531           IF (abs(dei)<0.01) dei = 0.01
    1532           sij(il, i, j) = anum/dei
    1533           sij(il, i, i) = 1.0
    1534           altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - rs(il, j)
    1535           altem = altem/bf2
    1536           cwat = clw(il, j)*(1.-ep(il,j))
    1537           stemp = sij(il, i, j)
    1538           IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
    1539             anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2)
    1540             denom = denom + lv(il, j)*(rr(il,i)-rti)
    1541             IF (abs(denom)<0.01) denom = 0.01
    1542             sij(il, i, j) = anum/denom
    1543             altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - &
    1544               rs(il, j)
    1545             altem = altem - (bf2-1.)*cwat
     907        ep(i, k) = 0.0
     908        sigp(i, k) = spfac
     909      END DO
     910    END DO
     911
     912    ! =====================================================================
     913    ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
     914    ! =====================================================================
     915
     916    ! ---       The procedure is to solve the equation.
     917    ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
     918
     919    ! ***  Calculate certain parcel quantities, including static energy   ***
     920
     921    DO i = 1, ncum
     922      ah0(i) = (cpd * (1. - qnk(i)) + cl * qnk(i)) * tnk(i) & ! debug     &
     923              ! +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
     924              + qnk(i) * (lv0 - clmcpv * (tnk(i) - 273.15)) + gznk(i)
     925    END DO
     926
     927
     928    ! ***  Find lifted parcel quantities above cloud base    ***
     929
     930    DO k = minorig + 1, nl
     931      DO i = 1, ncum
     932        ! ori        IF(k.ge.(icb(i)+1))THEN
     933        IF (k>=(icbs(i) + 1)) THEN ! convect3
     934          tg = t(i, k)
     935          qg = qs(i, k)
     936          ! debug          alv=lv0-clmcpv*(t(i,k)-t0)
     937          alv = lv0 - clmcpv * (t(i, k) - 273.15)
     938
     939          ! First iteration.
     940
     941          ! ori           s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
     942          s = cpd * (1. - qnk(i)) + cl * qnk(i) & ! convect3
     943                  + alv * alv * qg / (rrv * t(i, k) * t(i, k)) ! convect3
     944          s = 1. / s
     945          ! ori           ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
     946          ahg = cpd * tg + (cl - cpd) * qnk(i) * tg + alv * qg + gz(i, k) ! convect3
     947          tg = tg + s * (ah0(i) - ahg)
     948          ! ori           tg=max(tg,35.0)
     949          ! debug           tc=tg-t0
     950          tc = tg - 273.15
     951          denom = 243.5 + tc
     952          denom = max(denom, 1.0) ! convect3
     953          ! ori           IF(tc.ge.0.0)THEN
     954          es = 6.112 * exp(17.67 * tc / denom)
     955          ! ori           else
     956          ! ori            es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     957          ! ori           endif
     958          qg = eps * es / (p(i, k) - es * (1. - eps))
     959
     960          ! Second iteration.
     961
     962          ! ori           s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
     963          ! ori           s=1./s
     964          ! ori           ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
     965          ahg = cpd * tg + (cl - cpd) * qnk(i) * tg + alv * qg + gz(i, k) ! convect3
     966          tg = tg + s * (ah0(i) - ahg)
     967          ! ori           tg=max(tg,35.0)
     968          ! debug           tc=tg-t0
     969          tc = tg - 273.15
     970          denom = 243.5 + tc
     971          denom = max(denom, 1.0) ! convect3
     972          ! ori           IF(tc.ge.0.0)THEN
     973          es = 6.112 * exp(17.67 * tc / denom)
     974          ! ori           else
     975          ! ori            es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     976          ! ori           endif
     977          qg = eps * es / (p(i, k) - es * (1. - eps))
     978
     979          ! debug           alv=lv0-clmcpv*(t(i,k)-t0)
     980          alv = lv0 - clmcpv * (t(i, k) - 273.15)
     981          ! PRINT*,'cpd dans convect2 ',cpd
     982          ! PRINT*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
     983          ! PRINT*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
     984
     985          ! ori c approximation here:
     986          ! ori
     987          ! tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
     988
     989          ! convect3: no approximation:
     990          tp(i, k) = (ah0(i) - gz(i, k) - alv * qg) / (cpd + (cl - cpd) * qnk(i))
     991
     992          clw(i, k) = qnk(i) - qg
     993          clw(i, k) = max(0.0, clw(i, k))
     994          rg = qg / (1. - qnk(i))
     995          ! ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
     996          ! convect3: (qg utilise au lieu du vrai mixing ratio rg):
     997          tvp(i, k) = tp(i, k) * (1. + qg / eps - qnk(i)) ! whole thing
     998        END IF
     999      END DO
     1000    END DO
     1001
     1002    ! =====================================================================
     1003    ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
     1004    ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
     1005    ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
     1006    ! =====================================================================
     1007
     1008    ! ori      do 320 k=minorig+1,nl
     1009    DO k = 1, nl ! convect3
     1010      DO i = 1, ncum
     1011        pden = ptcrit - pbcrit
     1012        ep(i, k) = (plcl(i) - p(i, k) - pbcrit) / pden * epmax
     1013        ep(i, k) = amax1(ep(i, k), 0.0)
     1014        ep(i, k) = amin1(ep(i, k), epmax)
     1015        sigp(i, k) = spfac
     1016        ! ori          IF(k.ge.(nk(i)+1))THEN
     1017        ! ori            tca=tp(i,k)-t0
     1018        ! ori            IF(tca.ge.0.0)THEN
     1019        ! ori              elacrit=elcrit
     1020        ! ori            else
     1021        ! ori              elacrit=elcrit*(1.0-tca/tlcrit)
     1022        ! ori            endif
     1023        ! ori            elacrit=max(elacrit,0.0)
     1024        ! ori            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
     1025        ! ori            ep(i,k)=max(ep(i,k),0.0 )
     1026        ! ori            ep(i,k)=min(ep(i,k),1.0 )
     1027        ! ori            sigp(i,k)=sigs
     1028        ! ori          endif
     1029      END DO
     1030    END DO
     1031
     1032    ! =====================================================================
     1033    ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
     1034    ! --- VIRTUAL TEMPERATURE
     1035    ! =====================================================================
     1036
     1037    ! dans convect3, tvp est calcule en une seule fois, et sans retirer
     1038    ! l'eau condensee (~> reversible CAPE)
     1039
     1040    ! ori      do 340 k=minorig+1,nl
     1041    ! ori        do 330 i=1,ncum
     1042    ! ori        IF(k.ge.(icb(i)+1))THEN
     1043    ! ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
     1044    ! oric         PRINT*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
     1045    ! oric         PRINT*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
     1046    ! ori        endif
     1047    ! ori 330    continue
     1048    ! ori 340  continue
     1049
     1050    ! ori      do 350 i=1,ncum
     1051    ! ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
     1052    ! ori 350  continue
     1053
     1054    DO i = 1, ncum ! convect3
     1055      tp(i, nlp) = tp(i, nl) ! convect3
     1056    END DO ! convect3
     1057
     1058    ! =====================================================================
     1059    ! --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
     1060    ! =====================================================================
     1061
     1062    ! -- this is for convect3 only:
     1063
     1064    ! first estimate of buoyancy:
     1065
     1066    DO i = 1, ncum
     1067      DO k = 1, nl
     1068        buoy(i, k) = tvp(i, k) - tv(i, k)
     1069      END DO
     1070    END DO
     1071
     1072    ! set buoyancy=buoybase for all levels below base
     1073    ! for safety, set buoy(icb)=buoybase
     1074
     1075    DO i = 1, ncum
     1076      DO k = 1, nl
     1077        IF ((k>=icb(i)) .AND. (k<=nl) .AND. (p(i, k)>=pbase(i))) THEN
     1078          buoy(i, k) = buoybase(i)
     1079        END IF
     1080      END DO
     1081      ! IM cf. CRio/JYG 270807   buoy(icb(i),k)=buoybase(i)
     1082      buoy(i, icb(i)) = buoybase(i)
     1083    END DO
     1084
     1085    ! -- end convect3
     1086
     1087    ! =====================================================================
     1088    ! --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
     1089    ! --- LEVEL OF NEUTRAL BUOYANCY
     1090    ! =====================================================================
     1091
     1092    ! -- this is for convect3 only:
     1093
     1094    DO i = 1, ncum
     1095      inb(i) = nl - 1
     1096    END DO
     1097
     1098    DO i = 1, ncum
     1099      DO k = 1, nl - 1
     1100        IF ((k>=icb(i)) .AND. (buoy(i, k)<dtovsh)) THEN
     1101          inb(i) = min(inb(i), k)
     1102        END IF
     1103      END DO
     1104    END DO
     1105
     1106    ! -- end convect3
     1107
     1108    ! ori      do 510 i=1,ncum
     1109    ! ori        cape(i)=0.0
     1110    ! ori        capem(i)=0.0
     1111    ! ori        inb(i)=icb(i)+1
     1112    ! ori        inb1(i)=inb(i)
     1113    ! ori 510  continue
     1114
     1115    ! Originial Code
     1116
     1117    ! do 530 k=minorig+1,nl-1
     1118    ! do 520 i=1,ncum
     1119    ! IF(k.ge.(icb(i)+1))THEN
     1120    ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
     1121    ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
     1122    ! cape(i)=cape(i)+by
     1123    ! IF(by.ge.0.0)inb1(i)=k+1
     1124    ! IF(cape(i).gt.0.0)THEN
     1125    ! inb(i)=k+1
     1126    ! capem(i)=cape(i)
     1127    ! END IF
     1128    ! END IF
     1129    ! 520    continue
     1130    ! 530  continue
     1131    ! do 540 i=1,ncum
     1132    ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
     1133    ! cape(i)=capem(i)+byp
     1134    ! defrac=capem(i)-cape(i)
     1135    ! defrac=max(defrac,0.001)
     1136    ! frac(i)=-cape(i)/defrac
     1137    ! frac(i)=min(frac(i),1.0)
     1138    ! frac(i)=max(frac(i),0.0)
     1139    ! 540   continue
     1140
     1141    ! K Emanuel fix
     1142
     1143    ! CALL zilch(byp,ncum)
     1144    ! do 530 k=minorig+1,nl-1
     1145    ! do 520 i=1,ncum
     1146    ! IF(k.ge.(icb(i)+1))THEN
     1147    ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
     1148    ! cape(i)=cape(i)+by
     1149    ! IF(by.ge.0.0)inb1(i)=k+1
     1150    ! IF(cape(i).gt.0.0)THEN
     1151    ! inb(i)=k+1
     1152    ! capem(i)=cape(i)
     1153    ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
     1154    ! END IF
     1155    ! END IF
     1156    ! 520    continue
     1157    ! 530  continue
     1158    ! do 540 i=1,ncum
     1159    ! inb(i)=max(inb(i),inb1(i))
     1160    ! cape(i)=capem(i)+byp(i)
     1161    ! defrac=capem(i)-cape(i)
     1162    ! defrac=max(defrac,0.001)
     1163    ! frac(i)=-cape(i)/defrac
     1164    ! frac(i)=min(frac(i),1.0)
     1165    ! frac(i)=max(frac(i),0.0)
     1166    ! 540   continue
     1167
     1168    ! J Teixeira fix
     1169
     1170    ! ori      CALL zilch(byp,ncum)
     1171    ! ori      do 515 i=1,ncum
     1172    ! ori        lcape(i)=.TRUE.
     1173    ! ori 515  continue
     1174    ! ori      do 530 k=minorig+1,nl-1
     1175    ! ori        do 520 i=1,ncum
     1176    ! ori          IF(cape(i).lt.0.0)lcape(i)=.FALSE.
     1177    ! ori          if((k.ge.(icb(i)+1)).AND.lcape(i))THEN
     1178    ! ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
     1179    ! ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
     1180    ! ori            cape(i)=cape(i)+by
     1181    ! ori            IF(by.ge.0.0)inb1(i)=k+1
     1182    ! ori            IF(cape(i).gt.0.0)THEN
     1183    ! ori              inb(i)=k+1
     1184    ! ori              capem(i)=cape(i)
     1185    ! ori            endif
     1186    ! ori          endif
     1187    ! ori 520    continue
     1188    ! ori 530  continue
     1189    ! ori      do 540 i=1,ncum
     1190    ! ori          cape(i)=capem(i)+byp(i)
     1191    ! ori          defrac=capem(i)-cape(i)
     1192    ! ori          defrac=max(defrac,0.001)
     1193    ! ori          frac(i)=-cape(i)/defrac
     1194    ! ori          frac(i)=min(frac(i),1.0)
     1195    ! ori          frac(i)=max(frac(i),0.0)
     1196    ! ori 540  continue
     1197
     1198    ! =====================================================================
     1199    ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
     1200    ! =====================================================================
     1201
     1202    ! ym      do i=1,ncum*nlp
     1203    ! ym       hp(i,1)=h(i,1)
     1204    ! ym      enddo
     1205
     1206    DO k = 1, nlp
     1207      DO i = 1, ncum
     1208        hp(i, k) = h(i, k)
     1209      END DO
     1210    END DO
     1211
     1212    DO k = minorig + 1, nl
     1213      DO i = 1, ncum
     1214        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
     1215          hp(i, k) = h(i, nk(i)) + (lv(i, k) + (cpd - cpv) * t(i, k)) * ep(i, k) * clw(i, k &
     1216                  )
     1217        END IF
     1218      END DO
     1219    END DO
     1220
     1221  END SUBROUTINE cv30_undilute2
     1222
     1223  SUBROUTINE cv30_closure(nloc, ncum, nd, icb, inb, pbase, p, ph, tv, buoy, &
     1224          sig, w0, cape, m)
     1225    USE cvthermo_mod_h
     1226
     1227    IMPLICIT NONE
     1228
     1229    ! ===================================================================
     1230    ! ---  CLOSURE OF CONVECT3
     1231
     1232    ! vectorization: S. Bony
     1233    ! ===================================================================
     1234
     1235
     1236
     1237    ! input:
     1238    INTEGER ncum, nd, nloc
     1239    INTEGER icb(nloc), inb(nloc)
     1240    REAL pbase(nloc)
     1241    REAL p(nloc, nd), ph(nloc, nd + 1)
     1242    REAL tv(nloc, nd), buoy(nloc, nd)
     1243
     1244    ! input/output:
     1245    REAL sig(nloc, nd), w0(nloc, nd)
     1246
     1247    ! output:
     1248    REAL cape(nloc)
     1249    REAL m(nloc, nd)
     1250
     1251    ! local variables:
     1252    INTEGER i, j, k, icbmax
     1253    REAL deltap, fac, w, amu
     1254    REAL dtmin(nloc, nd), sigold(nloc, nd)
     1255
     1256    ! -------------------------------------------------------
     1257    ! -- Initialization
     1258    ! -------------------------------------------------------
     1259
     1260    DO k = 1, nl
     1261      DO i = 1, ncum
     1262        m(i, k) = 0.0
     1263      END DO
     1264    END DO
     1265
     1266    ! -------------------------------------------------------
     1267    ! -- Reset sig(i) and w0(i) for i>inb and i<icb
     1268    ! -------------------------------------------------------
     1269
     1270    ! update sig and w0 above LNB:
     1271
     1272    DO k = 1, nl - 1
     1273      DO i = 1, ncum
     1274        IF ((inb(i)<(nl - 1)) .AND. (k>=(inb(i) + 1))) THEN
     1275          sig(i, k) = beta * sig(i, k) + 2. * alpha * buoy(i, inb(i)) * abs(buoy(i, inb(&
     1276                  i)))
     1277          sig(i, k) = amax1(sig(i, k), 0.0)
     1278          w0(i, k) = beta * w0(i, k)
     1279        END IF
     1280      END DO
     1281    END DO
     1282
     1283    ! compute icbmax:
     1284
     1285    icbmax = 2
     1286    DO i = 1, ncum
     1287      icbmax = max(icbmax, icb(i))
     1288    END DO
     1289
     1290    ! update sig and w0 below cloud base:
     1291
     1292    DO k = 1, icbmax
     1293      DO i = 1, ncum
     1294        IF (k<=icb(i)) THEN
     1295          sig(i, k) = beta * sig(i, k) - 2. * alpha * buoy(i, icb(i)) * buoy(i, icb(i))
     1296          sig(i, k) = amax1(sig(i, k), 0.0)
     1297          w0(i, k) = beta * w0(i, k)
     1298        END IF
     1299      END DO
     1300    END DO
     1301
     1302    !      IF(inb.lt.(nl-1))THEN
     1303    !         do 85 i=inb+1,nl-1
     1304    !            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
     1305    !     1              abs(buoy(inb))
     1306    !            sig(i)=amax1(sig(i),0.0)
     1307    !            w0(i)=beta*w0(i)
     1308    !   85    continue
     1309    !      end if
     1310
     1311    !      do 87 i=1,icb
     1312    !         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
     1313    !         sig(i)=amax1(sig(i),0.0)
     1314    !         w0(i)=beta*w0(i)
     1315    !   87 continue
     1316
     1317    ! -------------------------------------------------------------
     1318    ! -- Reset fractional areas of updrafts and w0 at initial time
     1319    ! -- and after 10 time steps of no convection
     1320    ! -------------------------------------------------------------
     1321
     1322    DO k = 1, nl - 1
     1323      DO i = 1, ncum
     1324        IF (sig(i, nd)<1.5 .OR. sig(i, nd)>12.0) THEN
     1325          sig(i, k) = 0.0
     1326          w0(i, k) = 0.0
     1327        END IF
     1328      END DO
     1329    END DO
     1330
     1331    ! -------------------------------------------------------------
     1332    ! -- Calculate convective available potential energy (cape),
     1333    ! -- vertical velocity (w), fractional area covered by
     1334    ! -- undilute updraft (sig), and updraft mass flux (m)
     1335    ! -------------------------------------------------------------
     1336
     1337    DO i = 1, ncum
     1338      cape(i) = 0.0
     1339    END DO
     1340
     1341    ! compute dtmin (minimum buoyancy between ICB and given level k):
     1342
     1343    DO i = 1, ncum
     1344      DO k = 1, nl
     1345        dtmin(i, k) = 100.0
     1346      END DO
     1347    END DO
     1348
     1349    DO i = 1, ncum
     1350      DO k = 1, nl
     1351        DO j = minorig, nl
     1352          IF ((k>=(icb(i) + 1)) .AND. (k<=inb(i)) .AND. (j>=icb(i)) .AND. (j<=(k - &
     1353                  1))) THEN
     1354            dtmin(i, k) = amin1(dtmin(i, k), buoy(i, j))
    15461355          END IF
    1547           IF (sij(il,i,j)>0.0 .AND. sij(il,i,j)<0.95) THEN
    1548             qent(il, i, j) = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti
    1549             uent(il, i, j) = sij(il, i, j)*u(il, i) + &
    1550               (1.-sij(il,i,j))*u(il, nk(il))
    1551             vent(il, i, j) = sij(il, i, j)*v(il, i) + &
    1552               (1.-sij(il,i,j))*v(il, nk(il))
    1553             ! !!!      do k=1,ntra
    1554             ! !!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
    1555             ! !!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
    1556             ! !!!      end do
    1557             elij(il, i, j) = altem
    1558             elij(il, i, j) = amax1(0.0, elij(il,i,j))
    1559             ment(il, i, j) = m(il, i)/(1.-sij(il,i,j))
    1560             nent(il, i) = nent(il, i) + 1
    1561           END IF
    1562           sij(il, i, j) = amax1(0.0, sij(il,i,j))
    1563           sij(il, i, j) = amin1(1.0, sij(il,i,j))
    1564         END IF ! new
    1565       END DO
    1566     END DO
     1356        END DO
     1357      END DO
     1358    END DO
     1359
     1360    ! the interval on which cape is computed starts at pbase :
     1361    DO k = 1, nl
     1362      DO i = 1, ncum
     1363
     1364        IF ((k>=(icb(i) + 1)) .AND. (k<=inb(i))) THEN
     1365
     1366          deltap = min(pbase(i), ph(i, k - 1)) - min(pbase(i), ph(i, k))
     1367          cape(i) = cape(i) + rrd * buoy(i, k - 1) * deltap / p(i, k - 1)
     1368          cape(i) = amax1(0.0, cape(i))
     1369          sigold(i, k) = sig(i, k)
     1370
     1371          ! dtmin(i,k)=100.0
     1372          ! do 97 j=icb(i),k-1 ! mauvaise vectorisation
     1373          ! dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
     1374          ! 97     continue
     1375
     1376          sig(i, k) = beta * sig(i, k) + alpha * dtmin(i, k) * abs(dtmin(i, k))
     1377          sig(i, k) = amax1(sig(i, k), 0.0)
     1378          sig(i, k) = amin1(sig(i, k), 0.01)
     1379          fac = amin1(((dtcrit - dtmin(i, k)) / dtcrit), 1.0)
     1380          w = (1. - beta) * fac * sqrt(cape(i)) + beta * w0(i, k)
     1381          amu = 0.5 * (sig(i, k) + sigold(i, k)) * w
     1382          m(i, k) = amu * 0.007 * p(i, k) * (ph(i, k) - ph(i, k + 1)) / tv(i, k)
     1383          w0(i, k) = w
     1384        END IF
     1385
     1386      END DO
     1387    END DO
     1388
     1389    DO i = 1, ncum
     1390      w0(i, icb(i)) = 0.5 * w0(i, icb(i) + 1)
     1391      m(i, icb(i)) = 0.5 * m(i, icb(i) + 1) * (ph(i, icb(i)) - ph(i, icb(i) + 1)) / &
     1392              (ph(i, icb(i) + 1) - ph(i, icb(i) + 2))
     1393      sig(i, icb(i)) = sig(i, icb(i) + 1)
     1394      sig(i, icb(i) - 1) = sig(i, icb(i))
     1395    END DO
     1396
     1397
     1398    !      cape=0.0
     1399    !      do 98 i=icb+1,inb
     1400    !         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
     1401    !         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
     1402    !         dcape=rrd*buoy(i-1)*deltap/p(i-1)
     1403    !         dlnp=deltap/p(i-1)
     1404    !         cape=amax1(0.0,cape)
     1405    !         sigold=sig(i)
     1406
     1407    !         dtmin=100.0
     1408    !         do 97 j=icb,i-1
     1409    !            dtmin=amin1(dtmin,buoy(j))
     1410    !   97    continue
     1411
     1412    !         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
     1413    !         sig(i)=amax1(sig(i),0.0)
     1414    !         sig(i)=amin1(sig(i),0.01)
     1415    !         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
     1416    !         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
     1417    !         amu=0.5*(sig(i)+sigold)*w
     1418    !         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
     1419    !         w0(i)=w
     1420    !   98 continue
     1421    !      w0(icb)=0.5*w0(icb+1)
     1422    !      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
     1423    !      sig(icb)=sig(icb+1)
     1424    !      sig(icb-1)=sig(icb)
     1425
     1426  END SUBROUTINE cv30_closure
     1427
     1428  SUBROUTINE cv30_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, ph, t, rr, rs, &
     1429          u, v, tra, h, lv, qnk, hp, tv, tvp, ep, clw, m, sig, ment, qent, uent, &
     1430          vent, sij, elij, ments, qents, traent)
     1431    USE cvthermo_mod_h
     1432
     1433    IMPLICIT NONE
     1434
     1435    ! ---------------------------------------------------------------------
     1436    ! a faire:
     1437    ! - changer rr(il,1) -> qnk(il)
     1438    ! - vectorisation de la partie normalisation des flux (do 789...)
     1439    ! ---------------------------------------------------------------------
     1440
     1441
     1442
     1443    ! inputs:
     1444    INTEGER ncum, nd, na, ntra, nloc
     1445    INTEGER icb(nloc), inb(nloc), nk(nloc)
     1446    REAL sig(nloc, nd)
     1447    REAL qnk(nloc)
     1448    REAL ph(nloc, nd + 1)
     1449    REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
     1450    REAL u(nloc, nd), v(nloc, nd)
     1451    REAL tra(nloc, nd, ntra) ! input of convect3
     1452    REAL lv(nloc, na), h(nloc, na), hp(nloc, na)
     1453    REAL tv(nloc, na), tvp(nloc, na), ep(nloc, na), clw(nloc, na)
     1454    REAL m(nloc, na) ! input of convect3
     1455
     1456    ! outputs:
     1457    REAL ment(nloc, na, na), qent(nloc, na, na)
     1458    REAL uent(nloc, na, na), vent(nloc, na, na)
     1459    REAL sij(nloc, na, na), elij(nloc, na, na)
     1460    REAL traent(nloc, nd, nd, ntra)
     1461    REAL ments(nloc, nd, nd), qents(nloc, nd, nd)
     1462    REAL sigij(nloc, nd, nd)
     1463
     1464    ! local variables:
     1465    INTEGER i, j, k, il, im, jm
     1466    INTEGER num1, num2
     1467    INTEGER nent(nloc, na)
     1468    REAL rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
     1469    REAL alt, smid, sjmin, sjmax, delp, delm
     1470    REAL asij(nloc), smax(nloc), scrit(nloc)
     1471    REAL asum(nloc, nd), bsum(nloc, nd), csum(nloc, nd)
     1472    REAL wgh
     1473    REAL zm(nloc, na)
     1474    LOGICAL lwork(nloc)
     1475
     1476    ! =====================================================================
     1477    ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
     1478    ! =====================================================================
     1479
     1480    ! ori        do 360 i=1,ncum*nlp
     1481    DO j = 1, nl
     1482      DO i = 1, ncum
     1483        nent(i, j) = 0
     1484        ! in convect3, m is computed in cv3_closure
     1485        ! ori          m(i,1)=0.0
     1486      END DO
     1487    END DO
     1488
     1489    ! ori      do 400 k=1,nlp
     1490    ! ori       do 390 j=1,nlp
     1491    DO j = 1, nl
     1492      DO k = 1, nl
     1493        DO i = 1, ncum
     1494          qent(i, k, j) = rr(i, j)
     1495          uent(i, k, j) = u(i, j)
     1496          vent(i, k, j) = v(i, j)
     1497          elij(i, k, j) = 0.0
     1498          ! ym            ment(i,k,j)=0.0
     1499          ! ym            sij(i,k,j)=0.0
     1500        END DO
     1501      END DO
     1502    END DO
     1503
     1504    ! ym
     1505    ment(1:ncum, 1:nd, 1:nd) = 0.0
     1506    sij(1:ncum, 1:nd, 1:nd) = 0.0
    15671507
    15681508    ! do k=1,ntra
    1569     ! do j=minorig,nl
     1509    ! do j=1,nd  ! instead nlp
     1510    ! do i=1,nd ! instead nlp
    15701511    ! do il=1,ncum
    1571     ! if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
    1572     ! :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
    1573     ! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
    1574     ! :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
    1575     ! endif
     1512    ! traent(il,i,j,k)=tra(il,j,k)
    15761513    ! enddo
    15771514    ! enddo
    15781515    ! enddo
    1579 
    1580 
    1581     ! ***   if no air can entrain at level i assume that updraft detrains
    1582     ! ***
    1583     ! ***   at that level and calculate detrained air flux and properties
    1584     ! ***
    1585 
    1586 
    1587     ! @      do 170 i=icb(il),inb(il)
    1588 
    1589     DO il = 1, ncum
    1590       IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN
    1591         ! @      if(nent(il,i).eq.0)then
    1592         ment(il, i, i) = m(il, i)
    1593         qent(il, i, i) = rr(il, nk(il)) - ep(il, i)*clw(il, i)
    1594         uent(il, i, i) = u(il, nk(il))
    1595         vent(il, i, i) = v(il, nk(il))
    1596         elij(il, i, i) = clw(il, i)
    1597         ! MAF      sij(il,i,i)=1.0
    1598         sij(il, i, i) = 0.0
    1599       END IF
    1600     END DO
    1601   END DO
    1602 
    1603   ! do j=1,ntra
    1604   ! do i=minorig+1,nl
    1605   ! do il=1,ncum
    1606   ! if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
    1607   ! traent(il,i,i,j)=tra(il,nk(il),j)
    1608   ! endif
    1609   ! enddo
    1610   ! enddo
    1611   ! enddo
    1612 
    1613   DO j = minorig, nl
    1614     DO i = minorig, nl
     1516    ! enddo
     1517    zm(:, :) = 0.
     1518
     1519    ! =====================================================================
     1520    ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
     1521    ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
     1522    ! --- FRACTION (sij)
     1523    ! =====================================================================
     1524
     1525    DO i = minorig + 1, nl
     1526
     1527      DO j = minorig, nl
     1528        DO il = 1, ncum
     1529          IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il) - &
     1530                  1)) .AND. (j<=inb(il))) THEN
     1531
     1532            rti = rr(il, 1) - ep(il, i) * clw(il, i)
     1533            bf2 = 1. + lv(il, j) * lv(il, j) * rs(il, j) / (rrv * t(il, j) * t(il, j) * cpd)
     1534            anum = h(il, j) - hp(il, i) + (cpv - cpd) * t(il, j) * (rti - rr(il, j))
     1535            denom = h(il, i) - hp(il, i) + (cpd - cpv) * (rr(il, i) - rti) * t(il, j)
     1536            dei = denom
     1537            IF (abs(dei)<0.01) dei = 0.01
     1538            sij(il, i, j) = anum / dei
     1539            sij(il, i, i) = 1.0
     1540            altem = sij(il, i, j) * rr(il, i) + (1. - sij(il, i, j)) * rti - rs(il, j)
     1541            altem = altem / bf2
     1542            cwat = clw(il, j) * (1. - ep(il, j))
     1543            stemp = sij(il, i, j)
     1544            IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
     1545              anum = anum - lv(il, j) * (rti - rs(il, j) - cwat * bf2)
     1546              denom = denom + lv(il, j) * (rr(il, i) - rti)
     1547              IF (abs(denom)<0.01) denom = 0.01
     1548              sij(il, i, j) = anum / denom
     1549              altem = sij(il, i, j) * rr(il, i) + (1. - sij(il, i, j)) * rti - &
     1550                      rs(il, j)
     1551              altem = altem - (bf2 - 1.) * cwat
     1552            END IF
     1553            IF (sij(il, i, j)>0.0 .AND. sij(il, i, j)<0.95) THEN
     1554              qent(il, i, j) = sij(il, i, j) * rr(il, i) + (1. - sij(il, i, j)) * rti
     1555              uent(il, i, j) = sij(il, i, j) * u(il, i) + &
     1556                      (1. - sij(il, i, j)) * u(il, nk(il))
     1557              vent(il, i, j) = sij(il, i, j) * v(il, i) + &
     1558                      (1. - sij(il, i, j)) * v(il, nk(il))
     1559              ! !!!      do k=1,ntra
     1560              ! !!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
     1561              ! !!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
     1562              ! !!!      END DO
     1563              elij(il, i, j) = altem
     1564              elij(il, i, j) = amax1(0.0, elij(il, i, j))
     1565              ment(il, i, j) = m(il, i) / (1. - sij(il, i, j))
     1566              nent(il, i) = nent(il, i) + 1
     1567            END IF
     1568            sij(il, i, j) = amax1(0.0, sij(il, i, j))
     1569            sij(il, i, j) = amin1(1.0, sij(il, i, j))
     1570          END IF ! new
     1571        END DO
     1572      END DO
     1573
     1574      ! do k=1,ntra
     1575      ! do j=minorig,nl
     1576      ! do il=1,ncum
     1577      ! IF( (i.ge.icb(il)).AND.(i.le.inb(il)).AND.
     1578      ! :       (j.ge.(icb(il)-1)).AND.(j.le.inb(il)))THEN
     1579      ! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
     1580      ! :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
     1581      ! END IF
     1582      ! enddo
     1583      ! enddo
     1584      ! enddo
     1585
     1586
     1587      ! ***   if no air can entrain at level i assume that updraft detrains
     1588      ! ***
     1589      ! ***   at that level and calculate detrained air flux and properties
     1590      ! ***
     1591
     1592
     1593      ! @      do 170 i=icb(il),inb(il)
     1594
    16151595      DO il = 1, ncum
    1616         IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<= &
    1617             inb(il))) THEN
    1618           sigij(il, i, j) = sij(il, i, j)
     1596        IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il, i)==0)) THEN
     1597          ! @      IF(nent(il,i).EQ.0)THEN
     1598          ment(il, i, i) = m(il, i)
     1599          qent(il, i, i) = rr(il, nk(il)) - ep(il, i) * clw(il, i)
     1600          uent(il, i, i) = u(il, nk(il))
     1601          vent(il, i, i) = v(il, nk(il))
     1602          elij(il, i, i) = clw(il, i)
     1603          ! MAF      sij(il,i,i)=1.0
     1604          sij(il, i, i) = 0.0
    16191605        END IF
    16201606      END DO
    16211607    END DO
    1622   END DO
    1623   ! @      enddo
    1624 
    1625   ! @170   continue
    1626 
    1627   ! =====================================================================
    1628   ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
    1629   ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
    1630   ! =====================================================================
    1631 
    1632   ! ym      call zilch(asum,ncum*nd)
    1633   ! ym      call zilch(bsum,ncum*nd)
    1634   ! ym      call zilch(csum,ncum*nd)
    1635   CALL zilch(asum, nloc*nd)
    1636   CALL zilch(csum, nloc*nd)
    1637   CALL zilch(csum, nloc*nd)
    1638 
    1639   DO il = 1, ncum
    1640     lwork(il) = .FALSE.
    1641   END DO
    1642 
    1643   DO i = minorig + 1, nl
    1644 
    1645     num1 = 0
    1646     DO il = 1, ncum
    1647       IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1
    1648     END DO
    1649     IF (num1<=0) GO TO 789
    1650 
    1651 
    1652     DO il = 1, ncum
    1653       IF (i>=icb(il) .AND. i<=inb(il)) THEN
    1654         lwork(il) = (nent(il,i)/=0)
    1655         qp = rr(il, 1) - ep(il, i)*clw(il, i)
    1656         anum = h(il, i) - hp(il, i) - lv(il, i)*(qp-rs(il,i)) + &
    1657           (cpv-cpd)*t(il, i)*(qp-rr(il,i))
    1658         denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-qp) + &
    1659           (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
    1660         IF (abs(denom)<0.01) denom = 0.01
    1661         scrit(il) = anum/denom
    1662         alt = qp - rs(il, i) + scrit(il)*(rr(il,i)-qp)
    1663         IF (scrit(il)<=0.0 .OR. alt<=0.0) scrit(il) = 1.0
    1664         smax(il) = 0.0
    1665         asij(il) = 0.0
    1666       END IF
    1667     END DO
    1668 
    1669     DO j = nl, minorig, -1
    1670 
    1671       num2 = 0
    1672       DO il = 1, ncum
    1673         IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
    1674           il)-1) .AND. j<=inb(il) .AND. lwork(il)) num2 = num2 + 1
    1675       END DO
    1676       IF (num2<=0) GO TO 175
    1677 
    1678       DO il = 1, ncum
    1679         IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
    1680             il)-1) .AND. j<=inb(il) .AND. lwork(il)) THEN
    1681 
    1682           IF (sij(il,i,j)>1.0E-16 .AND. sij(il,i,j)<0.95) THEN
    1683             wgh = 1.0
    1684             IF (j>i) THEN
    1685               sjmax = amax1(sij(il,i,j+1), smax(il))
    1686               sjmax = amin1(sjmax, scrit(il))
    1687               smax(il) = amax1(sij(il,i,j), smax(il))
    1688               sjmin = amax1(sij(il,i,j-1), smax(il))
    1689               sjmin = amin1(sjmin, scrit(il))
    1690               IF (sij(il,i,j)<(smax(il)-1.0E-16)) wgh = 0.0
    1691               smid = amin1(sij(il,i,j), scrit(il))
    1692             ELSE
    1693               sjmax = amax1(sij(il,i,j+1), scrit(il))
    1694               smid = amax1(sij(il,i,j), scrit(il))
    1695               sjmin = 0.0
    1696               IF (j>1) sjmin = sij(il, i, j-1)
    1697               sjmin = amax1(sjmin, scrit(il))
    1698             END IF
    1699             delp = abs(sjmax-smid)
    1700             delm = abs(sjmin-smid)
    1701             asij(il) = asij(il) + wgh*(delp+delm)
    1702             ment(il, i, j) = ment(il, i, j)*(delp+delm)*wgh
    1703           END IF
    1704         END IF
    1705       END DO
    1706 
    1707 175 END DO
    1708 
    1709     DO il = 1, ncum
    1710       IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
    1711         asij(il) = amax1(1.0E-16, asij(il))
    1712         asij(il) = 1.0/asij(il)
    1713         asum(il, i) = 0.0
    1714         bsum(il, i) = 0.0
    1715         csum(il, i) = 0.0
    1716       END IF
    1717     END DO
    1718 
    1719     DO j = minorig, nl
    1720       DO il = 1, ncum
    1721         IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
    1722             il)-1) .AND. j<=inb(il)) THEN
    1723           ment(il, i, j) = ment(il, i, j)*asij(il)
    1724         END IF
    1725       END DO
    1726     END DO
    1727 
    1728     DO j = minorig, nl
    1729       DO il = 1, ncum
    1730         IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
    1731             il)-1) .AND. j<=inb(il)) THEN
    1732           asum(il, i) = asum(il, i) + ment(il, i, j)
    1733           ment(il, i, j) = ment(il, i, j)*sig(il, j)
    1734           bsum(il, i) = bsum(il, i) + ment(il, i, j)
    1735         END IF
    1736       END DO
    1737     END DO
    1738 
    1739     DO il = 1, ncum
    1740       IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
    1741         bsum(il, i) = amax1(bsum(il,i), 1.0E-16)
    1742         bsum(il, i) = 1.0/bsum(il, i)
    1743       END IF
    1744     END DO
    1745 
    1746     DO j = minorig, nl
    1747       DO il = 1, ncum
    1748         IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
    1749             il)-1) .AND. j<=inb(il)) THEN
    1750           ment(il, i, j) = ment(il, i, j)*asum(il, i)*bsum(il, i)
    1751         END IF
    1752       END DO
    1753     END DO
    1754 
    1755     DO j = minorig, nl
    1756       DO il = 1, ncum
    1757         IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
    1758             il)-1) .AND. j<=inb(il)) THEN
    1759           csum(il, i) = csum(il, i) + ment(il, i, j)
    1760         END IF
    1761       END DO
    1762     END DO
    1763 
    1764     DO il = 1, ncum
    1765       IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
    1766           csum(il,i)<m(il,i)) THEN
    1767         nent(il, i) = 0
    1768         ment(il, i, i) = m(il, i)
    1769         qent(il, i, i) = rr(il, 1) - ep(il, i)*clw(il, i)
    1770         uent(il, i, i) = u(il, nk(il))
    1771         vent(il, i, i) = v(il, nk(il))
    1772         elij(il, i, i) = clw(il, i)
    1773         ! MAF        sij(il,i,i)=1.0
    1774         sij(il, i, i) = 0.0
    1775       END IF
    1776     END DO ! il
    17771608
    17781609    ! do j=1,ntra
     1610    ! do i=minorig+1,nl
    17791611    ! do il=1,ncum
    1780     ! if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
    1781     ! :     .and. csum(il,i).lt.m(il,i) ) then
     1612    ! if (i.ge.icb(il) .AND. i.le.inb(il) .AND. nent(il,i).EQ.0) THEN
    17821613    ! traent(il,i,i,j)=tra(il,nk(il),j)
    1783     ! endif
     1614    ! END IF
    17841615    ! enddo
    17851616    ! enddo
    1786 789 END DO
    1787 
    1788   ! MAF: renormalisation de MENT
    1789   DO jm = 1, nd
    1790     DO im = 1, nd
     1617    ! enddo
     1618
     1619    DO j = minorig, nl
     1620      DO i = minorig, nl
     1621        DO il = 1, ncum
     1622          IF ((j>=(icb(il) - 1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<= &
     1623                  inb(il))) THEN
     1624            sigij(il, i, j) = sij(il, i, j)
     1625          END IF
     1626        END DO
     1627      END DO
     1628    END DO
     1629    ! @      enddo
     1630
     1631    ! @170   continue
     1632
     1633    ! =====================================================================
     1634    ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
     1635    ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
     1636    ! =====================================================================
     1637
     1638    ! ym      CALL zilch(asum,ncum*nd)
     1639    ! ym      CALL zilch(bsum,ncum*nd)
     1640    ! ym      CALL zilch(csum,ncum*nd)
     1641    CALL zilch(asum, nloc * nd)
     1642    CALL zilch(csum, nloc * nd)
     1643    CALL zilch(csum, nloc * nd)
     1644
     1645    DO il = 1, ncum
     1646      lwork(il) = .FALSE.
     1647    END DO
     1648
     1649    DO i = minorig + 1, nl
     1650
     1651      num1 = 0
    17911652      DO il = 1, ncum
    1792         zm(il, im) = zm(il, im) + (1.-sij(il,im,jm))*ment(il, im, jm)
    1793       END DO
    1794     END DO
    1795   END DO
    1796 
    1797   DO jm = 1, nd
    1798     DO im = 1, nd
     1653        IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1
     1654      END DO
     1655      IF (num1<=0) GO TO 789
     1656
    17991657      DO il = 1, ncum
    1800         IF (zm(il,im)/=0.) THEN
    1801           ment(il, im, jm) = ment(il, im, jm)*m(il, im)/zm(il, im)
     1658        IF (i>=icb(il) .AND. i<=inb(il)) THEN
     1659          lwork(il) = (nent(il, i)/=0)
     1660          qp = rr(il, 1) - ep(il, i) * clw(il, i)
     1661          anum = h(il, i) - hp(il, i) - lv(il, i) * (qp - rs(il, i)) + &
     1662                  (cpv - cpd) * t(il, i) * (qp - rr(il, i))
     1663          denom = h(il, i) - hp(il, i) + lv(il, i) * (rr(il, i) - qp) + &
     1664                  (cpd - cpv) * t(il, i) * (rr(il, i) - qp)
     1665          IF (abs(denom)<0.01) denom = 0.01
     1666          scrit(il) = anum / denom
     1667          alt = qp - rs(il, i) + scrit(il) * (rr(il, i) - qp)
     1668          IF (scrit(il)<=0.0 .OR. alt<=0.0) scrit(il) = 1.0
     1669          smax(il) = 0.0
     1670          asij(il) = 0.0
    18021671        END IF
    18031672      END DO
    1804     END DO
    1805   END DO
    1806 
    1807   DO jm = 1, nd
    1808     DO im = 1, nd
    1809       DO il = 1, ncum
    1810         qents(il, im, jm) = qent(il, im, jm)
    1811         ments(il, im, jm) = ment(il, im, jm)
    1812       END DO
    1813     END DO
    1814   END DO
    1815 
    1816   RETURN
    1817 END SUBROUTINE cv30_mixing
    1818 
    1819 
    1820 SUBROUTINE cv30_unsat(nloc, ncum, nd, na, ntra, icb, inb, t, rr, rs, gz, u, &
    1821     v, tra, p, ph, th, tv, lv, cpn, ep, sigp, clw, m, ment, elij, delt, plcl, &
    1822     mp, rp, up, vp, trap, wt, water, evap, b & ! RomP-jyg
    1823     , wdtraina, wdtrainm) ! 26/08/10  RomP-jyg
    1824   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    1825           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    1826   USE cvflag_mod_h, ONLY: icvflag_Tpa, cvflag_grav, cvflag_ice, ok_optim_yield, ok_entrain, ok_homo_tend, &
    1827     ok_convstop, ok_intermittent, cvflag_prec_eject, qsat_depends_on_qt, adiab_ascent_mass_flux_depends_on_ejectliq, keepbug_ice_frac
    1828   IMPLICIT NONE
    1829   include "cv30param.h"
    1830 
    1831   ! inputs:
    1832   INTEGER ncum, nd, na, ntra, nloc
    1833   INTEGER icb(nloc), inb(nloc)
    1834   REAL delt, plcl(nloc)
    1835   REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
    1836   REAL u(nloc, nd), v(nloc, nd)
    1837   REAL tra(nloc, nd, ntra)
    1838   REAL p(nloc, nd), ph(nloc, nd+1)
    1839   REAL th(nloc, na), gz(nloc, na)
    1840   REAL lv(nloc, na), ep(nloc, na), sigp(nloc, na), clw(nloc, na)
    1841   REAL cpn(nloc, na), tv(nloc, na)
    1842   REAL m(nloc, na), ment(nloc, na, na), elij(nloc, na, na)
    1843 
    1844   ! outputs:
    1845   REAL mp(nloc, na), rp(nloc, na), up(nloc, na), vp(nloc, na)
    1846   REAL water(nloc, na), evap(nloc, na), wt(nloc, na)
    1847   REAL trap(nloc, na, ntra)
    1848   REAL b(nloc, na)
    1849   ! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
    1850   ! lascendance adiabatique et des flux melanges Pa et Pm.
    1851   ! Distinction des wdtrain
    1852   ! Pa = wdtrainA     Pm = wdtrainM
    1853   REAL wdtraina(nloc, na), wdtrainm(nloc, na)
    1854 
    1855   ! local variables
    1856   INTEGER i, j, k, il, num1
    1857   REAL tinv, delti
    1858   REAL awat, afac, afac1, afac2, bfac
    1859   REAL pr1, pr2, sigt, b6, c6, revap, tevap, delth
    1860   REAL amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
    1861   REAL ampmax
    1862   REAL lvcp(nloc, na)
    1863   REAL wdtrain(nloc)
    1864   LOGICAL lwork(nloc)
    1865 
    1866 
    1867   ! ------------------------------------------------------
    1868 
    1869   delti = 1./delt
    1870   tinv = 1./3.
    1871 
    1872   mp(:, :) = 0.
    1873 
    1874   DO i = 1, nl
    1875     DO il = 1, ncum
    1876       mp(il, i) = 0.0
    1877       rp(il, i) = rr(il, i)
    1878       up(il, i) = u(il, i)
    1879       vp(il, i) = v(il, i)
    1880       wt(il, i) = 0.001
    1881       water(il, i) = 0.0
    1882       evap(il, i) = 0.0
    1883       b(il, i) = 0.0
    1884       lvcp(il, i) = lv(il, i)/cpn(il, i)
    1885     END DO
    1886   END DO
    1887 
    1888   ! do k=1,ntra
    1889   ! do i=1,nd
    1890   ! do il=1,ncum
    1891   ! trap(il,i,k)=tra(il,i,k)
    1892   ! enddo
    1893   ! enddo
    1894   ! enddo
    1895   ! ! RomP >>>
    1896   DO i = 1, nd
    1897     DO il = 1, ncum
    1898       wdtraina(il, i) = 0.0
    1899       wdtrainm(il, i) = 0.0
    1900     END DO
    1901   END DO
    1902   ! ! RomP <<<
    1903 
    1904   ! ***  check whether ep(inb)=0, if so, skip precipitating    ***
    1905   ! ***             downdraft calculation                      ***
    1906 
    1907 
    1908   DO il = 1, ncum
    1909     lwork(il) = .TRUE.
    1910     IF (ep(il,inb(il))<0.0001) lwork(il) = .FALSE.
    1911   END DO
    1912 
    1913   CALL zilch(wdtrain, ncum)
    1914 
    1915   DO i = nl + 1, 1, -1
    1916 
    1917     num1 = 0
    1918     DO il = 1, ncum
    1919       IF (i<=inb(il) .AND. lwork(il)) num1 = num1 + 1
    1920     END DO
    1921     IF (num1<=0) GO TO 400
    1922 
    1923 
    1924     ! ***  integrate liquid water equation to find condensed water   ***
    1925     ! ***                and condensed water flux                    ***
    1926 
    1927 
    1928 
    1929     ! ***                    begin downdraft loop                    ***
    1930 
    1931 
    1932 
    1933     ! ***              calculate detrained precipitation             ***
    1934 
    1935     DO il = 1, ncum
    1936       IF (i<=inb(il) .AND. lwork(il)) THEN
    1937         IF (cvflag_grav) THEN
    1938           wdtrain(il) = grav*ep(il, i)*m(il, i)*clw(il, i)
    1939           wdtraina(il, i) = wdtrain(il)/grav !   Pa  26/08/10   RomP
    1940         ELSE
    1941           wdtrain(il) = 10.0*ep(il, i)*m(il, i)*clw(il, i)
    1942           wdtraina(il, i) = wdtrain(il)/10. !   Pa  26/08/10   RomP
    1943         END IF
    1944       END IF
    1945     END DO
    1946 
    1947     IF (i>1) THEN
    1948 
    1949       DO j = 1, i - 1
     1673
     1674      DO j = nl, minorig, -1
     1675
     1676        num2 = 0
    19501677        DO il = 1, ncum
    1951           IF (i<=inb(il) .AND. lwork(il)) THEN
    1952             awat = elij(il, j, i) - (1.-ep(il,i))*clw(il, i)
    1953             awat = amax1(awat, 0.0)
    1954             IF (cvflag_grav) THEN
    1955               wdtrain(il) = wdtrain(il) + grav*awat*ment(il, j, i)
    1956             ELSE
    1957               wdtrain(il) = wdtrain(il) + 10.0*awat*ment(il, j, i)
     1678          IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb(&
     1679                  il) - 1) .AND. j<=inb(il) .AND. lwork(il)) num2 = num2 + 1
     1680        END DO
     1681        IF (num2<=0) GO TO 175
     1682
     1683        DO il = 1, ncum
     1684          IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb(&
     1685                  il) - 1) .AND. j<=inb(il) .AND. lwork(il)) THEN
     1686
     1687            IF (sij(il, i, j)>1.0E-16 .AND. sij(il, i, j)<0.95) THEN
     1688              wgh = 1.0
     1689              IF (j>i) THEN
     1690                sjmax = amax1(sij(il, i, j + 1), smax(il))
     1691                sjmax = amin1(sjmax, scrit(il))
     1692                smax(il) = amax1(sij(il, i, j), smax(il))
     1693                sjmin = amax1(sij(il, i, j - 1), smax(il))
     1694                sjmin = amin1(sjmin, scrit(il))
     1695                IF (sij(il, i, j)<(smax(il) - 1.0E-16)) wgh = 0.0
     1696                smid = amin1(sij(il, i, j), scrit(il))
     1697              ELSE
     1698                sjmax = amax1(sij(il, i, j + 1), scrit(il))
     1699                smid = amax1(sij(il, i, j), scrit(il))
     1700                sjmin = 0.0
     1701                IF (j>1) sjmin = sij(il, i, j - 1)
     1702                sjmin = amax1(sjmin, scrit(il))
     1703              END IF
     1704              delp = abs(sjmax - smid)
     1705              delm = abs(sjmin - smid)
     1706              asij(il) = asij(il) + wgh * (delp + delm)
     1707              ment(il, i, j) = ment(il, i, j) * (delp + delm) * wgh
    19581708            END IF
    19591709          END IF
    19601710        END DO
    1961       END DO
     1711
     1712      175 END DO
     1713
    19621714      DO il = 1, ncum
    1963         IF (cvflag_grav) THEN
    1964           wdtrainm(il, i) = wdtrain(il)/grav - wdtraina(il, i) !   Pm  26/08/10   RomP
    1965         ELSE
    1966           wdtrainm(il, i) = wdtrain(il)/10. - wdtraina(il, i) !   Pm  26/08/10   RomP
     1715        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
     1716          asij(il) = amax1(1.0E-16, asij(il))
     1717          asij(il) = 1.0 / asij(il)
     1718          asum(il, i) = 0.0
     1719          bsum(il, i) = 0.0
     1720          csum(il, i) = 0.0
    19671721        END IF
    19681722      END DO
    19691723
    1970     END IF
    1971 
    1972 
    1973     ! ***    find rain water and evaporation using provisional   ***
    1974     ! ***              estimates of rp(i)and rp(i-1)             ***
    1975 
    1976 
    1977     DO il = 1, ncum
    1978 
    1979       IF (i<=inb(il) .AND. lwork(il)) THEN
    1980 
    1981         wt(il, i) = 45.0
    1982 
    1983         IF (i<inb(il)) THEN
    1984           rp(il, i) = rp(il, i+1) + (cpd*(t(il,i+1)-t(il, &
    1985             i))+gz(il,i+1)-gz(il,i))/lv(il, i)
    1986           rp(il, i) = 0.5*(rp(il,i)+rr(il,i))
    1987         END IF
    1988         rp(il, i) = amax1(rp(il,i), 0.0)
    1989         rp(il, i) = amin1(rp(il,i), rs(il,i))
    1990         rp(il, inb(il)) = rr(il, inb(il))
    1991 
    1992         IF (i==1) THEN
    1993           afac = p(il, 1)*(rs(il,1)-rp(il,1))/(1.0E4+2000.0*p(il,1)*rs(il,1))
    1994         ELSE
    1995           rp(il, i-1) = rp(il, i) + (cpd*(t(il,i)-t(il, &
    1996             i-1))+gz(il,i)-gz(il,i-1))/lv(il, i)
    1997           rp(il, i-1) = 0.5*(rp(il,i-1)+rr(il,i-1))
    1998           rp(il, i-1) = amin1(rp(il,i-1), rs(il,i-1))
    1999           rp(il, i-1) = amax1(rp(il,i-1), 0.0)
    2000           afac1 = p(il, i)*(rs(il,i)-rp(il,i))/(1.0E4+2000.0*p(il,i)*rs(il,i) &
    2001             )
    2002           afac2 = p(il, i-1)*(rs(il,i-1)-rp(il,i-1))/ &
    2003             (1.0E4+2000.0*p(il,i-1)*rs(il,i-1))
    2004           afac = 0.5*(afac1+afac2)
    2005         END IF
    2006         IF (i==inb(il)) afac = 0.0
    2007         afac = amax1(afac, 0.0)
    2008         bfac = 1./(sigd*wt(il,i))
    2009 
    2010         ! jyg1
    2011         ! cc        sigt=1.0
    2012         ! cc        if(i.ge.icb)sigt=sigp(i)
    2013         ! prise en compte de la variation progressive de sigt dans
    2014         ! les couches icb et icb-1:
    2015         ! pour plcl<ph(i+1), pr1=0 & pr2=1
    2016         ! pour plcl>ph(i),   pr1=1 & pr2=0
    2017         ! pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
    2018         ! sur le nuage, et pr2 est la proportion sous la base du
    2019         ! nuage.
    2020         pr1 = (plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
    2021         pr1 = max(0., min(1.,pr1))
    2022         pr2 = (ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
    2023         pr2 = max(0., min(1.,pr2))
    2024         sigt = sigp(il, i)*pr1 + pr2
    2025         ! jyg2
    2026 
    2027         b6 = bfac*50.*sigd*(ph(il,i)-ph(il,i+1))*sigt*afac
    2028         c6 = water(il, i+1) + bfac*wdtrain(il) - 50.*sigd*bfac*(ph(il,i)-ph( &
    2029           il,i+1))*evap(il, i+1)
    2030         IF (c6>0.0) THEN
    2031           revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
    2032           evap(il, i) = sigt*afac*revap
    2033           water(il, i) = revap*revap
    2034         ELSE
    2035           evap(il, i) = -evap(il, i+1) + 0.02*(wdtrain(il)+sigd*wt(il,i)* &
    2036             water(il,i+1))/(sigd*(ph(il,i)-ph(il,i+1)))
    2037         END IF
    2038 
    2039         ! ***  calculate precipitating downdraft mass flux under     ***
    2040         ! ***              hydrostatic approximation                 ***
    2041 
    2042         IF (i/=1) THEN
    2043 
    2044           tevap = amax1(0.0, evap(il,i))
    2045           delth = amax1(0.001, (th(il,i)-th(il,i-1)))
    2046           IF (cvflag_grav) THEN
    2047             mp(il, i) = 100.*ginv*lvcp(il, i)*sigd*tevap*(p(il,i-1)-p(il,i))/ &
    2048               delth
    2049           ELSE
    2050             mp(il, i) = 10.*lvcp(il, i)*sigd*tevap*(p(il,i-1)-p(il,i))/delth
    2051           END IF
    2052 
    2053           ! ***           if hydrostatic assumption fails,             ***
    2054           ! ***   solve cubic difference equation for downdraft theta  ***
    2055           ! ***  and mass flux from two simultaneous differential eqns ***
    2056 
    2057           amfac = sigd*sigd*70.0*ph(il, i)*(p(il,i-1)-p(il,i))* &
    2058             (th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
    2059           amp2 = abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
    2060           IF (amp2>(0.1*amfac)) THEN
    2061             xf = 100.0*sigd*sigd*sigd*(ph(il,i)-ph(il,i+1))
    2062             tf = b(il, i) - 5.0*(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i)* &
    2063               sigd*th(il,i))
    2064             af = xf*tf + mp(il, i+1)*mp(il, i+1)*tinv
    2065             bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + &
    2066               50.*(p(il,i-1)-p(il,i))*xf*tevap
    2067             fac2 = 1.0
    2068             IF (bf<0.0) fac2 = -1.0
    2069             bf = abs(bf)
    2070             ur = 0.25*bf*bf - af*af*af*tinv*tinv*tinv
    2071             IF (ur>=0.0) THEN
    2072               sru = sqrt(ur)
    2073               fac = 1.0
    2074               IF ((0.5*bf-sru)<0.0) fac = -1.0
    2075               mp(il, i) = mp(il, i+1)*tinv + (0.5*bf+sru)**tinv + &
    2076                 fac*(abs(0.5*bf-sru))**tinv
    2077             ELSE
    2078               d = atan(2.*sqrt(-ur)/(bf+1.0E-28))
    2079               IF (fac2<0.0) d = 3.14159 - d
    2080               mp(il, i) = mp(il, i+1)*tinv + 2.*sqrt(af*tinv)*cos(d*tinv)
    2081             END IF
    2082             mp(il, i) = amax1(0.0, mp(il,i))
    2083 
    2084             IF (cvflag_grav) THEN
    2085               ! jyg : il y a vraisemblablement une erreur dans la ligne 2
    2086               ! suivante:
    2087               ! il faut diviser par (mp(il,i)*sigd*grav) et non par
    2088               ! (mp(il,i)+sigd*0.1).
    2089               ! Et il faut bien revoir les facteurs 100.
    2090               b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap/(mp(il, &
    2091                 i)+sigd*0.1) - 10.0*(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i &
    2092                 )*sigd*th(il,i))
    2093             ELSE
    2094               b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap/(mp(il, &
    2095                 i)+sigd*0.1) - 10.0*(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i &
    2096                 )*sigd*th(il,i))
    2097             END IF
    2098             b(il, i-1) = amax1(b(il,i-1), 0.0)
    2099           END IF
    2100 
    2101           ! ***         limit magnitude of mp(i) to meet cfl condition
    2102           ! ***
    2103 
    2104           ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti
    2105           amp2 = 2.0*(ph(il,i-1)-ph(il,i))*delti
    2106           ampmax = amin1(ampmax, amp2)
    2107           mp(il, i) = amin1(mp(il,i), ampmax)
    2108 
    2109           ! ***      force mp to decrease linearly to zero
    2110           ! ***
    2111           ! ***       between cloud base and the surface
    2112           ! ***
    2113 
    2114           IF (p(il,i)>p(il,icb(il))) THEN
    2115             mp(il, i) = mp(il, icb(il))*(p(il,1)-p(il,i))/ &
    2116               (p(il,1)-p(il,icb(il)))
    2117           END IF
    2118 
    2119         END IF ! i.eq.1
    2120 
    2121         ! ***       find mixing ratio of precipitating downdraft     ***
    2122 
    2123 
    2124         IF (i/=inb(il)) THEN
    2125 
    2126           rp(il, i) = rr(il, i)
    2127 
    2128           IF (mp(il,i)>mp(il,i+1)) THEN
    2129 
    2130             IF (cvflag_grav) THEN
    2131               rp(il, i) = rp(il, i+1)*mp(il, i+1) + &
    2132                 rr(il, i)*(mp(il,i)-mp(il,i+1)) + 100.*ginv*0.5*sigd*(ph(il,i &
    2133                 )-ph(il,i+1))*(evap(il,i+1)+evap(il,i))
    2134             ELSE
    2135               rp(il, i) = rp(il, i+1)*mp(il, i+1) + &
    2136                 rr(il, i)*(mp(il,i)-mp(il,i+1)) + 5.*sigd*(ph(il,i)-ph(il,i+1 &
    2137                 ))*(evap(il,i+1)+evap(il,i))
    2138             END IF
    2139             rp(il, i) = rp(il, i)/mp(il, i)
    2140             up(il, i) = up(il, i+1)*mp(il, i+1) + u(il, i)*(mp(il,i)-mp(il,i+ &
    2141               1))
    2142             up(il, i) = up(il, i)/mp(il, i)
    2143             vp(il, i) = vp(il, i+1)*mp(il, i+1) + v(il, i)*(mp(il,i)-mp(il,i+ &
    2144               1))
    2145             vp(il, i) = vp(il, i)/mp(il, i)
    2146 
    2147             ! do j=1,ntra
    2148             ! trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
    2149             ! testmaf     :            +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
    2150             ! :            +tra(il,i,j)*(mp(il,i)-mp(il,i+1))
    2151             ! trap(il,i,j)=trap(il,i,j)/mp(il,i)
    2152             ! end do
    2153 
    2154           ELSE
    2155 
    2156             IF (mp(il,i+1)>1.0E-16) THEN
    2157               IF (cvflag_grav) THEN
    2158                 rp(il, i) = rp(il, i+1) + 100.*ginv*0.5*sigd*(ph(il,i)-ph(il, &
    2159                   i+1))*(evap(il,i+1)+evap(il,i))/mp(il, i+1)
    2160               ELSE
    2161                 rp(il, i) = rp(il, i+1) + 5.*sigd*(ph(il,i)-ph(il,i+1))*(evap &
    2162                   (il,i+1)+evap(il,i))/mp(il, i+1)
    2163               END IF
    2164               up(il, i) = up(il, i+1)
    2165               vp(il, i) = vp(il, i+1)
    2166 
    2167               ! do j=1,ntra
    2168               ! trap(il,i,j)=trap(il,i+1,j)
    2169               ! end do
    2170 
    2171             END IF
    2172           END IF
    2173           rp(il, i) = amin1(rp(il,i), rs(il,i))
    2174           rp(il, i) = amax1(rp(il,i), 0.0)
    2175 
    2176         END IF
    2177       END IF
    2178     END DO
    2179 
    2180 400 END DO
    2181 
    2182   RETURN
    2183 END SUBROUTINE cv30_unsat
    2184 
    2185 SUBROUTINE cv30_yield(nloc, ncum, nd, na, ntra, icb, inb, delt, t, rr, u, v, &
    2186     tra, gz, p, ph, h, hp, lv, cpn, th, ep, clw, m, tp, mp, rp, up, vp, trap, &
    2187     wt, water, evap, b, ment, qent, uent, vent, nent, elij, traent, sig, tv, &
    2188     tvp, iflag, precip, vprecip, ft, fr, fu, fv, ftra, upwd, dnwd, dnwd0, ma, &
    2189     mike, tls, tps, qcondc, wd)
    2190   USE cvflag_mod_h, ONLY: icvflag_Tpa, cvflag_grav, cvflag_ice, ok_optim_yield, ok_entrain, ok_homo_tend, &
    2191           ok_convstop, ok_intermittent, cvflag_prec_eject, qsat_depends_on_qt, adiab_ascent_mass_flux_depends_on_ejectliq, keepbug_ice_frac
    2192   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    2193           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    2194   IMPLICIT NONE
    2195 
    2196   include "cv30param.h"
    2197   include "conema3.h"
    2198 
    2199   ! inputs:
    2200   INTEGER ncum, nd, na, ntra, nloc
    2201   INTEGER icb(nloc), inb(nloc)
    2202   REAL delt
    2203   REAL t(nloc, nd), rr(nloc, nd), u(nloc, nd), v(nloc, nd)
    2204   REAL tra(nloc, nd, ntra), sig(nloc, nd)
    2205   REAL gz(nloc, na), ph(nloc, nd+1), h(nloc, na), hp(nloc, na)
    2206   REAL th(nloc, na), p(nloc, nd), tp(nloc, na)
    2207   REAL lv(nloc, na), cpn(nloc, na), ep(nloc, na), clw(nloc, na)
    2208   REAL m(nloc, na), mp(nloc, na), rp(nloc, na), up(nloc, na)
    2209   REAL vp(nloc, na), wt(nloc, nd), trap(nloc, nd, ntra)
    2210   REAL water(nloc, na), evap(nloc, na), b(nloc, na)
    2211   REAL ment(nloc, na, na), qent(nloc, na, na), uent(nloc, na, na)
    2212   ! ym      real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
    2213   REAL vent(nloc, na, na), elij(nloc, na, na)
    2214   INTEGER nent(nloc, na)
    2215   REAL traent(nloc, na, na, ntra)
    2216   REAL tv(nloc, nd), tvp(nloc, nd)
    2217 
    2218   ! input/output:
    2219   INTEGER iflag(nloc)
    2220 
    2221   ! outputs:
    2222   REAL precip(nloc)
    2223   REAL vprecip(nloc, nd+1)
    2224   REAL ft(nloc, nd), fr(nloc, nd), fu(nloc, nd), fv(nloc, nd)
    2225   REAL ftra(nloc, nd, ntra)
    2226   REAL upwd(nloc, nd), dnwd(nloc, nd), ma(nloc, nd)
    2227   REAL dnwd0(nloc, nd), mike(nloc, nd)
    2228   REAL tls(nloc, nd), tps(nloc, nd)
    2229   REAL qcondc(nloc, nd) ! cld
    2230   REAL wd(nloc) ! gust
    2231 
    2232   ! local variables:
    2233   INTEGER i, k, il, n, j, num1
    2234   REAL rat, awat, delti
    2235   REAL ax, bx, cx, dx, ex
    2236   REAL cpinv, rdcp, dpinv
    2237   REAL lvcp(nloc, na), mke(nloc, na)
    2238   REAL am(nloc), work(nloc), ad(nloc), amp1(nloc)
    2239   ! !!      real up1(nloc), dn1(nloc)
    2240   REAL up1(nloc, nd, nd), dn1(nloc, nd, nd)
    2241   REAL asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
    2242   REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
    2243   REAL siga(nloc, nd), sax(nloc, nd), mac(nloc, nd) ! cld
    2244 
    2245 
    2246   ! -------------------------------------------------------------
    2247 
    2248   ! initialization:
    2249 
    2250   delti = 1.0/delt
    2251 
    2252   DO il = 1, ncum
    2253     precip(il) = 0.0
    2254     wd(il) = 0.0 ! gust
    2255     vprecip(il, nd+1) = 0.
    2256   END DO
    2257 
    2258   DO i = 1, nd
    2259     DO il = 1, ncum
    2260       vprecip(il, i) = 0.0
    2261       ft(il, i) = 0.0
    2262       fr(il, i) = 0.0
    2263       fu(il, i) = 0.0
    2264       fv(il, i) = 0.0
    2265       qcondc(il, i) = 0.0 ! cld
    2266       qcond(il, i) = 0.0 ! cld
    2267       nqcond(il, i) = 0.0 ! cld
    2268     END DO
    2269   END DO
    2270 
    2271   ! do j=1,ntra
    2272   ! do i=1,nd
    2273   ! do il=1,ncum
    2274   ! ftra(il,i,j)=0.0
    2275   ! enddo
    2276   ! enddo
    2277   ! enddo
    2278 
    2279   DO i = 1, nl
    2280     DO il = 1, ncum
    2281       lvcp(il, i) = lv(il, i)/cpn(il, i)
    2282     END DO
    2283   END DO
    2284 
    2285 
    2286 
    2287   ! ***  calculate surface precipitation in mm/day     ***
    2288 
    2289   DO il = 1, ncum
    2290     IF (ep(il,inb(il))>=0.0001) THEN
    2291       IF (cvflag_grav) THEN
    2292         precip(il) = wt(il, 1)*sigd*water(il, 1)*86400.*1000./(rowl*grav)
    2293       ELSE
    2294         precip(il) = wt(il, 1)*sigd*water(il, 1)*8640.
    2295       END IF
    2296     END IF
    2297   END DO
    2298 
    2299   ! ***  CALCULATE VERTICAL PROFILE OF  PRECIPITATIONs IN kg/m2/s  ===
    2300 
    2301   ! MAF rajout pour lessivage
    2302   DO k = 1, nl
    2303     DO il = 1, ncum
    2304       IF (k<=inb(il)) THEN
    2305         IF (cvflag_grav) THEN
    2306           vprecip(il, k) = wt(il, k)*sigd*water(il, k)/grav
    2307         ELSE
    2308           vprecip(il, k) = wt(il, k)*sigd*water(il, k)/10.
    2309         END IF
    2310       END IF
    2311     END DO
    2312   END DO
    2313 
    2314 
    2315   ! ***  Calculate downdraft velocity scale    ***
    2316   ! ***  NE PAS UTILISER POUR L'INSTANT ***
    2317 
    2318   ! !      do il=1,ncum
    2319   ! !        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
    2320   ! !     :                                  /(sigd*p(il,icb(il)))
    2321   ! !      enddo
    2322 
    2323 
    2324   ! ***  calculate tendencies of lowest level potential temperature  ***
    2325   ! ***                      and mixing ratio                        ***
    2326 
    2327   DO il = 1, ncum
    2328     work(il) = 1.0/(ph(il,1)-ph(il,2))
    2329     am(il) = 0.0
    2330   END DO
    2331 
    2332   DO k = 2, nl
    2333     DO il = 1, ncum
    2334       IF (k<=inb(il)) THEN
    2335         am(il) = am(il) + m(il, k)
    2336       END IF
    2337     END DO
    2338   END DO
    2339 
    2340   DO il = 1, ncum
    2341 
    2342     ! convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
    2343     IF (cvflag_grav) THEN
    2344       IF ((0.01*grav*work(il)*am(il))>=delti) iflag(il) = 1 !consist vect
    2345       ft(il, 1) = 0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)+(gz(il,2)-gz(il, &
    2346         1))/cpn(il,1))
    2347     ELSE
    2348       IF ((0.1*work(il)*am(il))>=delti) iflag(il) = 1 !consistency vect
    2349       ft(il, 1) = 0.1*work(il)*am(il)*(t(il,2)-t(il,1)+(gz(il,2)-gz(il, &
    2350         1))/cpn(il,1))
    2351     END IF
    2352 
    2353     ft(il, 1) = ft(il, 1) - 0.5*lvcp(il, 1)*sigd*(evap(il,1)+evap(il,2))
    2354 
    2355     IF (cvflag_grav) THEN
    2356       ft(il, 1) = ft(il, 1) - 0.009*grav*sigd*mp(il, 2)*t(il, 1)*b(il, 1)* &
    2357         work(il)
    2358     ELSE
    2359       ft(il, 1) = ft(il, 1) - 0.09*sigd*mp(il, 2)*t(il, 1)*b(il, 1)*work(il)
    2360     END IF
    2361 
    2362     ft(il, 1) = ft(il, 1) + 0.01*sigd*wt(il, 1)*(cl-cpd)*water(il, 2)*(t(il,2 &
    2363       )-t(il,1))*work(il)/cpn(il, 1)
    2364 
    2365     IF (cvflag_grav) THEN
    2366       ! jyg1  Correction pour mieux conserver l'eau (conformite avec
    2367       ! CONVECT4.3)
    2368       ! (sb: pour l'instant, on ne fait que le chgt concernant grav, pas
    2369       ! evap)
    2370       fr(il, 1) = 0.01*grav*mp(il, 2)*(rp(il,2)-rr(il,1))*work(il) + &
    2371         sigd*0.5*(evap(il,1)+evap(il,2))
    2372       ! +tard     :          +sigd*evap(il,1)
    2373 
    2374       fr(il, 1) = fr(il, 1) + 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
    2375 
    2376       fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il, &
    2377         1))+am(il)*(u(il,2)-u(il,1)))
    2378       fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il, &
    2379         1))+am(il)*(v(il,2)-v(il,1)))
    2380     ELSE ! cvflag_grav
    2381       fr(il, 1) = 0.1*mp(il, 2)*(rp(il,2)-rr(il,1))*work(il) + &
    2382         sigd*0.5*(evap(il,1)+evap(il,2))
    2383       fr(il, 1) = fr(il, 1) + 0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
    2384       fu(il, 1) = fu(il, 1) + 0.1*work(il)*(mp(il,2)*(up(il,2)-u(il, &
    2385         1))+am(il)*(u(il,2)-u(il,1)))
    2386       fv(il, 1) = fv(il, 1) + 0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il, &
    2387         1))+am(il)*(v(il,2)-v(il,1)))
    2388     END IF ! cvflag_grav
    2389 
    2390   END DO ! il
    2391 
    2392   ! do j=1,ntra
    2393   ! do il=1,ncum
    2394   ! if (cvflag_grav) then
    2395   ! ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
    2396   ! :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
    2397   ! :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
    2398   ! else
    2399   ! ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
    2400   ! :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
    2401   ! :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
    2402   ! endif
    2403   ! enddo
    2404   ! enddo
    2405 
    2406   DO j = 2, nl
    2407     DO il = 1, ncum
    2408       IF (j<=inb(il)) THEN
    2409         IF (cvflag_grav) THEN
    2410           fr(il, 1) = fr(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il, &
    2411             j,1)-rr(il,1))
    2412           fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(uent(il, &
    2413             j,1)-u(il,1))
    2414           fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(vent(il, &
    2415             j,1)-v(il,1))
    2416         ELSE ! cvflag_grav
    2417           fr(il, 1) = fr(il, 1) + 0.1*work(il)*ment(il, j, 1)*(qent(il,j,1)- &
    2418             rr(il,1))
    2419           fu(il, 1) = fu(il, 1) + 0.1*work(il)*ment(il, j, 1)*(uent(il,j,1)-u &
    2420             (il,1))
    2421           fv(il, 1) = fv(il, 1) + 0.1*work(il)*ment(il, j, 1)*(vent(il,j,1)-v &
    2422             (il,1))
    2423         END IF ! cvflag_grav
    2424       END IF ! j
    2425     END DO
    2426   END DO
    2427 
    2428   ! do k=1,ntra
    2429   ! do j=2,nl
    2430   ! do il=1,ncum
    2431   ! if (j.le.inb(il)) then
    2432 
    2433   ! if (cvflag_grav) then
    2434   ! ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
    2435   ! :                *(traent(il,j,1,k)-tra(il,1,k))
    2436   ! else
    2437   ! ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
    2438   ! :                *(traent(il,j,1,k)-tra(il,1,k))
    2439   ! endif
    2440 
    2441   ! endif
    2442   ! enddo
    2443   ! enddo
    2444   ! enddo
    2445 
    2446 
    2447   ! ***  calculate tendencies of potential temperature and mixing ratio  ***
    2448   ! ***               at levels above the lowest level                   ***
    2449 
    2450   ! ***  first find the net saturated updraft and downdraft mass fluxes  ***
    2451   ! ***                      through each level                          ***
    2452 
    2453 
    2454   DO i = 2, nl + 1 ! newvecto: mettre nl au lieu nl+1?
    2455 
    2456     num1 = 0
    2457     DO il = 1, ncum
    2458       IF (i<=inb(il)) num1 = num1 + 1
    2459     END DO
    2460     IF (num1<=0) GO TO 500
    2461 
    2462     CALL zilch(amp1, ncum)
    2463     CALL zilch(ad, ncum)
    2464 
    2465     DO k = i + 1, nl + 1
    2466       DO il = 1, ncum
    2467         IF (i<=inb(il) .AND. k<=(inb(il)+1)) THEN
    2468           amp1(il) = amp1(il) + m(il, k)
    2469         END IF
    2470       END DO
    2471     END DO
    2472 
    2473     DO k = 1, i
    2474       DO j = i + 1, nl + 1
     1724      DO j = minorig, nl
    24751725        DO il = 1, ncum
    2476           IF (i<=inb(il) .AND. j<=(inb(il)+1)) THEN
    2477             amp1(il) = amp1(il) + ment(il, k, j)
     1726          IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb(&
     1727                  il) - 1) .AND. j<=inb(il)) THEN
     1728            ment(il, i, j) = ment(il, i, j) * asij(il)
    24781729          END IF
    24791730        END DO
    24801731      END DO
    2481     END DO
    2482 
    2483     DO k = 1, i - 1
    2484       DO j = i, nl + 1 ! newvecto: nl au lieu nl+1?
     1732
     1733      DO j = minorig, nl
    24851734        DO il = 1, ncum
    2486           IF (i<=inb(il) .AND. j<=inb(il)) THEN
    2487             ad(il) = ad(il) + ment(il, j, k)
     1735          IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb(&
     1736                  il) - 1) .AND. j<=inb(il)) THEN
     1737            asum(il, i) = asum(il, i) + ment(il, i, j)
     1738            ment(il, i, j) = ment(il, i, j) * sig(il, j)
     1739            bsum(il, i) = bsum(il, i) + ment(il, i, j)
    24881740          END IF
    24891741        END DO
    24901742      END DO
    2491     END DO
    2492 
    2493     DO il = 1, ncum
    2494       IF (i<=inb(il)) THEN
    2495         dpinv = 1.0/(ph(il,i)-ph(il,i+1))
    2496         cpinv = 1.0/cpn(il, i)
    2497 
    2498         ! convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
    2499         IF (cvflag_grav) THEN
    2500           IF ((0.01*grav*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
    2501         ELSE
    2502           IF ((0.1*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
     1743
     1744      DO il = 1, ncum
     1745        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
     1746          bsum(il, i) = amax1(bsum(il, i), 1.0E-16)
     1747          bsum(il, i) = 1.0 / bsum(il, i)
    25031748        END IF
    2504 
    2505         IF (cvflag_grav) THEN
    2506           ft(il, i) = 0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il, &
    2507             i)+(gz(il,i+1)-gz(il,i))*cpinv)-ad(il)*(t(il,i)-t(il, &
    2508             i-1)+(gz(il,i)-gz(il,i-1))*cpinv)) - 0.5*sigd*lvcp(il, i)*(evap( &
    2509             il,i)+evap(il,i+1))
    2510           rat = cpn(il, i-1)*cpinv
    2511           ft(il, i) = ft(il, i) - 0.009*grav*sigd*(mp(il,i+1)*t(il,i)*b(il,i) &
    2512             -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
    2513           ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, i, i)*(hp(il,i)-h( &
    2514             il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
    2515         ELSE ! cvflag_grav
    2516           ft(il, i) = 0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il, &
    2517             i)+(gz(il,i+1)-gz(il,i))*cpinv)-ad(il)*(t(il,i)-t(il, &
    2518             i-1)+(gz(il,i)-gz(il,i-1))*cpinv)) - 0.5*sigd*lvcp(il, i)*(evap( &
    2519             il,i)+evap(il,i+1))
    2520           rat = cpn(il, i-1)*cpinv
    2521           ft(il, i) = ft(il, i) - 0.09*sigd*(mp(il,i+1)*t(il,i)*b(il,i)-mp(il &
    2522             ,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
    2523           ft(il, i) = ft(il, i) + 0.1*dpinv*ment(il, i, i)*(hp(il,i)-h(il,i)+ &
    2524             t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
    2525         END IF ! cvflag_grav
    2526 
    2527 
    2528         ft(il, i) = ft(il, i) + 0.01*sigd*wt(il, i)*(cl-cpd)*water(il, i+1)*( &
    2529           t(il,i+1)-t(il,i))*dpinv*cpinv
    2530 
    2531         IF (cvflag_grav) THEN
    2532           fr(il, i) = 0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il, &
    2533             i))-ad(il)*(rr(il,i)-rr(il,i-1)))
    2534           fu(il, i) = fu(il, i) + 0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il, &
    2535             i))-ad(il)*(u(il,i)-u(il,i-1)))
    2536           fv(il, i) = fv(il, i) + 0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il, &
    2537             i))-ad(il)*(v(il,i)-v(il,i-1)))
    2538         ELSE ! cvflag_grav
    2539           fr(il, i) = 0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il, &
    2540             i))-ad(il)*(rr(il,i)-rr(il,i-1)))
    2541           fu(il, i) = fu(il, i) + 0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il, &
    2542             i))-ad(il)*(u(il,i)-u(il,i-1)))
    2543           fv(il, i) = fv(il, i) + 0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il, &
    2544             i))-ad(il)*(v(il,i)-v(il,i-1)))
    2545         END IF ! cvflag_grav
    2546 
    2547       END IF ! i
     1749      END DO
     1750
     1751      DO j = minorig, nl
     1752        DO il = 1, ncum
     1753          IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb(&
     1754                  il) - 1) .AND. j<=inb(il)) THEN
     1755            ment(il, i, j) = ment(il, i, j) * asum(il, i) * bsum(il, i)
     1756          END IF
     1757        END DO
     1758      END DO
     1759
     1760      DO j = minorig, nl
     1761        DO il = 1, ncum
     1762          IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb(&
     1763                  il) - 1) .AND. j<=inb(il)) THEN
     1764            csum(il, i) = csum(il, i) + ment(il, i, j)
     1765          END IF
     1766        END DO
     1767      END DO
     1768
     1769      DO il = 1, ncum
     1770        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
     1771                csum(il, i)<m(il, i)) THEN
     1772          nent(il, i) = 0
     1773          ment(il, i, i) = m(il, i)
     1774          qent(il, i, i) = rr(il, 1) - ep(il, i) * clw(il, i)
     1775          uent(il, i, i) = u(il, nk(il))
     1776          vent(il, i, i) = v(il, nk(il))
     1777          elij(il, i, i) = clw(il, i)
     1778          ! MAF        sij(il,i,i)=1.0
     1779          sij(il, i, i) = 0.0
     1780        END IF
     1781      END DO ! il
     1782
     1783      ! do j=1,ntra
     1784      ! do il=1,ncum
     1785      ! if ( i.ge.icb(il) .AND. i.le.inb(il) .AND. lwork(il)
     1786      ! :     .AND. csum(il,i).lt.m(il,i) ) THEN
     1787      ! traent(il,i,i,j)=tra(il,nk(il),j)
     1788      ! END IF
     1789      ! enddo
     1790      ! enddo
     1791    789 END DO
     1792
     1793    ! MAF: renormalisation de MENT
     1794    DO jm = 1, nd
     1795      DO im = 1, nd
     1796        DO il = 1, ncum
     1797          zm(il, im) = zm(il, im) + (1. - sij(il, im, jm)) * ment(il, im, jm)
     1798        END DO
     1799      END DO
     1800    END DO
     1801
     1802    DO jm = 1, nd
     1803      DO im = 1, nd
     1804        DO il = 1, ncum
     1805          IF (zm(il, im)/=0.) THEN
     1806            ment(il, im, jm) = ment(il, im, jm) * m(il, im) / zm(il, im)
     1807          END IF
     1808        END DO
     1809      END DO
     1810    END DO
     1811
     1812    DO jm = 1, nd
     1813      DO im = 1, nd
     1814        DO il = 1, ncum
     1815          qents(il, im, jm) = qent(il, im, jm)
     1816          ments(il, im, jm) = ment(il, im, jm)
     1817        END DO
     1818      END DO
     1819    END DO
     1820
     1821  END SUBROUTINE cv30_mixing
     1822
     1823
     1824  SUBROUTINE cv30_unsat(nloc, ncum, nd, na, ntra, icb, inb, t, rr, rs, gz, u, &
     1825          v, tra, p, ph, th, tv, lv, cpn, ep, sigp, clw, m, ment, elij, delt, plcl, &
     1826          mp, rp, up, vp, trap, wt, water, evap, b & ! RomP-jyg
     1827          , wdtraina, wdtrainm) ! 26/08/10  RomP-jyg
     1828    USE cvflag_mod_h
     1829    USE cvthermo_mod_h
     1830
     1831    IMPLICIT NONE
     1832
     1833
     1834
     1835    ! inputs:
     1836    INTEGER ncum, nd, na, ntra, nloc
     1837    INTEGER icb(nloc), inb(nloc)
     1838    REAL delt, plcl(nloc)
     1839    REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
     1840    REAL u(nloc, nd), v(nloc, nd)
     1841    REAL tra(nloc, nd, ntra)
     1842    REAL p(nloc, nd), ph(nloc, nd + 1)
     1843    REAL th(nloc, na), gz(nloc, na)
     1844    REAL lv(nloc, na), ep(nloc, na), sigp(nloc, na), clw(nloc, na)
     1845    REAL cpn(nloc, na), tv(nloc, na)
     1846    REAL m(nloc, na), ment(nloc, na, na), elij(nloc, na, na)
     1847
     1848    ! outputs:
     1849    REAL mp(nloc, na), rp(nloc, na), up(nloc, na), vp(nloc, na)
     1850    REAL water(nloc, na), evap(nloc, na), wt(nloc, na)
     1851    REAL trap(nloc, na, ntra)
     1852    REAL b(nloc, na)
     1853    ! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
     1854    ! lascendance adiabatique et des flux melanges Pa et Pm.
     1855    ! Distinction des wdtrain
     1856    ! Pa = wdtrainA     Pm = wdtrainM
     1857    REAL wdtraina(nloc, na), wdtrainm(nloc, na)
     1858
     1859    ! local variables
     1860    INTEGER i, j, k, il, num1
     1861    REAL tinv, delti
     1862    REAL awat, afac, afac1, afac2, bfac
     1863    REAL pr1, pr2, sigt, b6, c6, revap, tevap, delth
     1864    REAL amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
     1865    REAL ampmax
     1866    REAL lvcp(nloc, na)
     1867    REAL wdtrain(nloc)
     1868    LOGICAL lwork(nloc)
     1869
     1870
     1871    ! ------------------------------------------------------
     1872
     1873    delti = 1. / delt
     1874    tinv = 1. / 3.
     1875
     1876    mp(:, :) = 0.
     1877
     1878    DO i = 1, nl
     1879      DO il = 1, ncum
     1880        mp(il, i) = 0.0
     1881        rp(il, i) = rr(il, i)
     1882        up(il, i) = u(il, i)
     1883        vp(il, i) = v(il, i)
     1884        wt(il, i) = 0.001
     1885        water(il, i) = 0.0
     1886        evap(il, i) = 0.0
     1887        b(il, i) = 0.0
     1888        lvcp(il, i) = lv(il, i) / cpn(il, i)
     1889      END DO
    25481890    END DO
    25491891
    25501892    ! do k=1,ntra
     1893    ! do i=1,nd
    25511894    ! do il=1,ncum
    2552     ! if (i.le.inb(il)) then
    2553     ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
    2554     ! cpinv=1.0/cpn(il,i)
    2555     ! if (cvflag_grav) then
    2556     ! ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
    2557     ! :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
    2558     ! :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
    2559     ! else
    2560     ! ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
    2561     ! :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
    2562     ! :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
    2563     ! endif
    2564     ! endif
    2565     ! enddo
    2566     ! enddo
    2567 
    2568     DO k = 1, i - 1
    2569       DO il = 1, ncum
    2570         IF (i<=inb(il)) THEN
    2571           dpinv = 1.0/(ph(il,i)-ph(il,i+1))
    2572           cpinv = 1.0/cpn(il, i)
    2573 
    2574           awat = elij(il, k, i) - (1.-ep(il,i))*clw(il, i)
    2575           awat = amax1(awat, 0.0)
    2576 
    2577           IF (cvflag_grav) THEN
    2578             fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k &
    2579               ,i)-awat-rr(il,i))
    2580             fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
    2581               ,i)-u(il,i))
    2582             fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k &
    2583               ,i)-v(il,i))
    2584           ELSE ! cvflag_grav
    2585             fr(il, i) = fr(il, i) + 0.1*dpinv*ment(il, k, i)*(qent(il,k,i)- &
    2586               awat-rr(il,i))
    2587             fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
    2588               ,i)-u(il,i))
    2589             fv(il, i) = fv(il, i) + 0.1*dpinv*ment(il, k, i)*(vent(il,k,i)-v( &
    2590               il,i))
    2591           END IF ! cvflag_grav
    2592 
    2593           ! (saturated updrafts resulting from mixing)        ! cld
    2594           qcond(il, i) = qcond(il, i) + (elij(il,k,i)-awat) ! cld
    2595           nqcond(il, i) = nqcond(il, i) + 1. ! cld
    2596         END IF ! i
    2597       END DO
    2598     END DO
    2599 
    2600     ! do j=1,ntra
    2601     ! do k=1,i-1
    2602     ! do il=1,ncum
    2603     ! if (i.le.inb(il)) then
    2604     ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
    2605     ! cpinv=1.0/cpn(il,i)
    2606     ! if (cvflag_grav) then
    2607     ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
    2608     ! :        *(traent(il,k,i,j)-tra(il,i,j))
    2609     ! else
    2610     ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
    2611     ! :        *(traent(il,k,i,j)-tra(il,i,j))
    2612     ! endif
    2613     ! endif
     1895    ! trap(il,i,k)=tra(il,i,k)
    26141896    ! enddo
    26151897    ! enddo
    26161898    ! enddo
    2617 
    2618     DO k = i, nl + 1
     1899    ! RomP >>>
     1900    DO i = 1, nd
    26191901      DO il = 1, ncum
    2620         IF (i<=inb(il) .AND. k<=inb(il)) THEN
    2621           dpinv = 1.0/(ph(il,i)-ph(il,i+1))
    2622           cpinv = 1.0/cpn(il, i)
    2623 
     1902        wdtraina(il, i) = 0.0
     1903        wdtrainm(il, i) = 0.0
     1904      END DO
     1905    END DO
     1906    ! RomP <<<
     1907
     1908    ! ***  check whether ep(inb)=0, if so, skip precipitating    ***
     1909    ! ***             downdraft calculation                      ***
     1910
     1911    DO il = 1, ncum
     1912      lwork(il) = .TRUE.
     1913      IF (ep(il, inb(il))<0.0001) lwork(il) = .FALSE.
     1914    END DO
     1915
     1916    CALL zilch(wdtrain, ncum)
     1917
     1918    DO i = nl + 1, 1, -1
     1919
     1920      num1 = 0
     1921      DO il = 1, ncum
     1922        IF (i<=inb(il) .AND. lwork(il)) num1 = num1 + 1
     1923      END DO
     1924      IF (num1<=0) GO TO 400
     1925
     1926
     1927      ! ***  integrate liquid water equation to find condensed water   ***
     1928      ! ***                and condensed water flux                    ***
     1929
     1930
     1931
     1932      ! ***                    begin downdraft loop                    ***
     1933
     1934
     1935
     1936      ! ***              calculate detrained precipitation             ***
     1937
     1938      DO il = 1, ncum
     1939        IF (i<=inb(il) .AND. lwork(il)) THEN
    26241940          IF (cvflag_grav) THEN
    2625             fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k &
    2626               ,i)-rr(il,i))
    2627             fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
    2628               ,i)-u(il,i))
    2629             fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k &
    2630               ,i)-v(il,i))
    2631           ELSE ! cvflag_grav
    2632             fr(il, i) = fr(il, i) + 0.1*dpinv*ment(il, k, i)*(qent(il,k,i)-rr &
    2633               (il,i))
    2634             fu(il, i) = fu(il, i) + 0.1*dpinv*ment(il, k, i)*(uent(il,k,i)-u( &
    2635               il,i))
    2636             fv(il, i) = fv(il, i) + 0.1*dpinv*ment(il, k, i)*(vent(il,k,i)-v( &
    2637               il,i))
    2638           END IF ! cvflag_grav
    2639         END IF ! i and k
     1941            wdtrain(il) = grav * ep(il, i) * m(il, i) * clw(il, i)
     1942            wdtraina(il, i) = wdtrain(il) / grav !   Pa  26/08/10   RomP
     1943          ELSE
     1944            wdtrain(il) = 10.0 * ep(il, i) * m(il, i) * clw(il, i)
     1945            wdtraina(il, i) = wdtrain(il) / 10. !   Pa  26/08/10   RomP
     1946          END IF
     1947        END IF
     1948      END DO
     1949
     1950      IF (i>1) THEN
     1951
     1952        DO j = 1, i - 1
     1953          DO il = 1, ncum
     1954            IF (i<=inb(il) .AND. lwork(il)) THEN
     1955              awat = elij(il, j, i) - (1. - ep(il, i)) * clw(il, i)
     1956              awat = amax1(awat, 0.0)
     1957              IF (cvflag_grav) THEN
     1958                wdtrain(il) = wdtrain(il) + grav * awat * ment(il, j, i)
     1959              ELSE
     1960                wdtrain(il) = wdtrain(il) + 10.0 * awat * ment(il, j, i)
     1961              END IF
     1962            END IF
     1963          END DO
     1964        END DO
     1965        DO il = 1, ncum
     1966          IF (cvflag_grav) THEN
     1967            wdtrainm(il, i) = wdtrain(il) / grav - wdtraina(il, i) !   Pm  26/08/10   RomP
     1968          ELSE
     1969            wdtrainm(il, i) = wdtrain(il) / 10. - wdtraina(il, i) !   Pm  26/08/10   RomP
     1970          END IF
     1971        END DO
     1972
     1973      END IF
     1974
     1975
     1976      ! ***    find rain water and evaporation using provisional   ***
     1977      ! ***              estimates of rp(i)and rp(i-1)             ***
     1978
     1979      DO il = 1, ncum
     1980
     1981        IF (i<=inb(il) .AND. lwork(il)) THEN
     1982
     1983          wt(il, i) = 45.0
     1984
     1985          IF (i<inb(il)) THEN
     1986            rp(il, i) = rp(il, i + 1) + (cpd * (t(il, i + 1) - t(il, &
     1987                    i)) + gz(il, i + 1) - gz(il, i)) / lv(il, i)
     1988            rp(il, i) = 0.5 * (rp(il, i) + rr(il, i))
     1989          END IF
     1990          rp(il, i) = amax1(rp(il, i), 0.0)
     1991          rp(il, i) = amin1(rp(il, i), rs(il, i))
     1992          rp(il, inb(il)) = rr(il, inb(il))
     1993
     1994          IF (i==1) THEN
     1995            afac = p(il, 1) * (rs(il, 1) - rp(il, 1)) / (1.0E4 + 2000.0 * p(il, 1) * rs(il, 1))
     1996          ELSE
     1997            rp(il, i - 1) = rp(il, i) + (cpd * (t(il, i) - t(il, &
     1998                    i - 1)) + gz(il, i) - gz(il, i - 1)) / lv(il, i)
     1999            rp(il, i - 1) = 0.5 * (rp(il, i - 1) + rr(il, i - 1))
     2000            rp(il, i - 1) = amin1(rp(il, i - 1), rs(il, i - 1))
     2001            rp(il, i - 1) = amax1(rp(il, i - 1), 0.0)
     2002            afac1 = p(il, i) * (rs(il, i) - rp(il, i)) / (1.0E4 + 2000.0 * p(il, i) * rs(il, i) &
     2003                    )
     2004            afac2 = p(il, i - 1) * (rs(il, i - 1) - rp(il, i - 1)) / &
     2005                    (1.0E4 + 2000.0 * p(il, i - 1) * rs(il, i - 1))
     2006            afac = 0.5 * (afac1 + afac2)
     2007          END IF
     2008          IF (i==inb(il)) afac = 0.0
     2009          afac = amax1(afac, 0.0)
     2010          bfac = 1. / (sigd * wt(il, i))
     2011
     2012          ! jyg1
     2013          ! cc        sigt=1.0
     2014          ! cc        IF(i.ge.icb)sigt=sigp(i)
     2015          ! prise en compte de la variation progressive de sigt dans
     2016          ! les couches icb et icb-1:
     2017          ! pour plcl<ph(i+1), pr1=0 & pr2=1
     2018          ! pour plcl>ph(i),   pr1=1 & pr2=0
     2019          ! pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
     2020          ! sur le nuage, et pr2 est la proportion sous la base du
     2021          ! nuage.
     2022          pr1 = (plcl(il) - ph(il, i + 1)) / (ph(il, i) - ph(il, i + 1))
     2023          pr1 = max(0., min(1., pr1))
     2024          pr2 = (ph(il, i) - plcl(il)) / (ph(il, i) - ph(il, i + 1))
     2025          pr2 = max(0., min(1., pr2))
     2026          sigt = sigp(il, i) * pr1 + pr2
     2027          ! jyg2
     2028
     2029          b6 = bfac * 50. * sigd * (ph(il, i) - ph(il, i + 1)) * sigt * afac
     2030          c6 = water(il, i + 1) + bfac * wdtrain(il) - 50. * sigd * bfac * (ph(il, i) - ph(&
     2031                  il, i + 1)) * evap(il, i + 1)
     2032          IF (c6>0.0) THEN
     2033            revap = 0.5 * (-b6 + sqrt(b6 * b6 + 4. * c6))
     2034            evap(il, i) = sigt * afac * revap
     2035            water(il, i) = revap * revap
     2036          ELSE
     2037            evap(il, i) = -evap(il, i + 1) + 0.02 * (wdtrain(il) + sigd * wt(il, i) * &
     2038                    water(il, i + 1)) / (sigd * (ph(il, i) - ph(il, i + 1)))
     2039          END IF
     2040
     2041          ! ***  calculate precipitating downdraft mass flux under     ***
     2042          ! ***              hydrostatic approximation                 ***
     2043
     2044          IF (i/=1) THEN
     2045
     2046            tevap = amax1(0.0, evap(il, i))
     2047            delth = amax1(0.001, (th(il, i) - th(il, i - 1)))
     2048            IF (cvflag_grav) THEN
     2049              mp(il, i) = 100. * ginv * lvcp(il, i) * sigd * tevap * (p(il, i - 1) - p(il, i)) / &
     2050                      delth
     2051            ELSE
     2052              mp(il, i) = 10. * lvcp(il, i) * sigd * tevap * (p(il, i - 1) - p(il, i)) / delth
     2053            END IF
     2054
     2055            ! ***           if hydrostatic assumption fails,             ***
     2056            ! ***   solve cubic difference equation for downdraft theta  ***
     2057            ! ***  and mass flux from two simultaneous differential eqns ***
     2058
     2059            amfac = sigd * sigd * 70.0 * ph(il, i) * (p(il, i - 1) - p(il, i)) * &
     2060                    (th(il, i) - th(il, i - 1)) / (tv(il, i) * th(il, i))
     2061            amp2 = abs(mp(il, i + 1) * mp(il, i + 1) - mp(il, i) * mp(il, i))
     2062            IF (amp2>(0.1 * amfac)) THEN
     2063              xf = 100.0 * sigd * sigd * sigd * (ph(il, i) - ph(il, i + 1))
     2064              tf = b(il, i) - 5.0 * (th(il, i) - th(il, i - 1)) * t(il, i) / (lvcp(il, i) * &
     2065                      sigd * th(il, i))
     2066              af = xf * tf + mp(il, i + 1) * mp(il, i + 1) * tinv
     2067              bf = 2. * (tinv * mp(il, i + 1))**3 + tinv * mp(il, i + 1) * xf * tf + &
     2068                      50. * (p(il, i - 1) - p(il, i)) * xf * tevap
     2069              fac2 = 1.0
     2070              IF (bf<0.0) fac2 = -1.0
     2071              bf = abs(bf)
     2072              ur = 0.25 * bf * bf - af * af * af * tinv * tinv * tinv
     2073              IF (ur>=0.0) THEN
     2074                sru = sqrt(ur)
     2075                fac = 1.0
     2076                IF ((0.5 * bf - sru)<0.0) fac = -1.0
     2077                mp(il, i) = mp(il, i + 1) * tinv + (0.5 * bf + sru)**tinv + &
     2078                        fac * (abs(0.5 * bf - sru))**tinv
     2079              ELSE
     2080                d = atan(2. * sqrt(-ur) / (bf + 1.0E-28))
     2081                IF (fac2<0.0) d = 3.14159 - d
     2082                mp(il, i) = mp(il, i + 1) * tinv + 2. * sqrt(af * tinv) * cos(d * tinv)
     2083              END IF
     2084              mp(il, i) = amax1(0.0, mp(il, i))
     2085
     2086              IF (cvflag_grav) THEN
     2087                ! jyg : il y a vraisemblablement une erreur dans la ligne 2
     2088                ! suivante:
     2089                ! il faut diviser par (mp(il,i)*sigd*grav) et non par
     2090                ! (mp(il,i)+sigd*0.1).
     2091                ! Et il faut bien revoir les facteurs 100.
     2092                b(il, i - 1) = b(il, i) + 100.0 * (p(il, i - 1) - p(il, i)) * tevap / (mp(il, &
     2093                        i) + sigd * 0.1) - 10.0 * (th(il, i) - th(il, i - 1)) * t(il, i) / (lvcp(il, i &
     2094                        ) * sigd * th(il, i))
     2095              ELSE
     2096                b(il, i - 1) = b(il, i) + 100.0 * (p(il, i - 1) - p(il, i)) * tevap / (mp(il, &
     2097                        i) + sigd * 0.1) - 10.0 * (th(il, i) - th(il, i - 1)) * t(il, i) / (lvcp(il, i &
     2098                        ) * sigd * th(il, i))
     2099              END IF
     2100              b(il, i - 1) = amax1(b(il, i - 1), 0.0)
     2101            END IF
     2102
     2103            ! ***         limit magnitude of mp(i) to meet cfl condition
     2104            ! ***
     2105
     2106            ampmax = 2.0 * (ph(il, i) - ph(il, i + 1)) * delti
     2107            amp2 = 2.0 * (ph(il, i - 1) - ph(il, i)) * delti
     2108            ampmax = amin1(ampmax, amp2)
     2109            mp(il, i) = amin1(mp(il, i), ampmax)
     2110
     2111            ! ***      force mp to decrease linearly to zero
     2112            ! ***
     2113            ! ***       between cloud base and the surface
     2114            ! ***
     2115
     2116            IF (p(il, i)>p(il, icb(il))) THEN
     2117              mp(il, i) = mp(il, icb(il)) * (p(il, 1) - p(il, i)) / &
     2118                      (p(il, 1) - p(il, icb(il)))
     2119            END IF
     2120
     2121          END IF ! i.EQ.1
     2122
     2123          ! ***       find mixing ratio of precipitating downdraft     ***
     2124
     2125          IF (i/=inb(il)) THEN
     2126
     2127            rp(il, i) = rr(il, i)
     2128
     2129            IF (mp(il, i)>mp(il, i + 1)) THEN
     2130
     2131              IF (cvflag_grav) THEN
     2132                rp(il, i) = rp(il, i + 1) * mp(il, i + 1) + &
     2133                        rr(il, i) * (mp(il, i) - mp(il, i + 1)) + 100. * ginv * 0.5 * sigd * (ph(il, i &
     2134                        ) - ph(il, i + 1)) * (evap(il, i + 1) + evap(il, i))
     2135              ELSE
     2136                rp(il, i) = rp(il, i + 1) * mp(il, i + 1) + &
     2137                        rr(il, i) * (mp(il, i) - mp(il, i + 1)) + 5. * sigd * (ph(il, i) - ph(il, i + 1 &
     2138                        )) * (evap(il, i + 1) + evap(il, i))
     2139              END IF
     2140              rp(il, i) = rp(il, i) / mp(il, i)
     2141              up(il, i) = up(il, i + 1) * mp(il, i + 1) + u(il, i) * (mp(il, i) - mp(il, i + &
     2142                      1))
     2143              up(il, i) = up(il, i) / mp(il, i)
     2144              vp(il, i) = vp(il, i + 1) * mp(il, i + 1) + v(il, i) * (mp(il, i) - mp(il, i + &
     2145                      1))
     2146              vp(il, i) = vp(il, i) / mp(il, i)
     2147
     2148              ! do j=1,ntra
     2149              ! trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
     2150              ! testmaf     :            +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
     2151              ! :            +tra(il,i,j)*(mp(il,i)-mp(il,i+1))
     2152              ! trap(il,i,j)=trap(il,i,j)/mp(il,i)
     2153              ! END DO
     2154
     2155            ELSE
     2156
     2157              IF (mp(il, i + 1)>1.0E-16) THEN
     2158                IF (cvflag_grav) THEN
     2159                  rp(il, i) = rp(il, i + 1) + 100. * ginv * 0.5 * sigd * (ph(il, i) - ph(il, &
     2160                          i + 1)) * (evap(il, i + 1) + evap(il, i)) / mp(il, i + 1)
     2161                ELSE
     2162                  rp(il, i) = rp(il, i + 1) + 5. * sigd * (ph(il, i) - ph(il, i + 1)) * (evap &
     2163                          (il, i + 1) + evap(il, i)) / mp(il, i + 1)
     2164                END IF
     2165                up(il, i) = up(il, i + 1)
     2166                vp(il, i) = vp(il, i + 1)
     2167
     2168                ! do j=1,ntra
     2169                ! trap(il,i,j)=trap(il,i+1,j)
     2170                ! END DO
     2171
     2172              END IF
     2173            END IF
     2174            rp(il, i) = amin1(rp(il, i), rs(il, i))
     2175            rp(il, i) = amax1(rp(il, i), 0.0)
     2176
     2177          END IF
     2178        END IF
     2179      END DO
     2180
     2181    400 END DO
     2182
     2183  END SUBROUTINE cv30_unsat
     2184
     2185  SUBROUTINE cv30_yield(nloc, ncum, nd, na, ntra, icb, inb, delt, t, rr, u, v, &
     2186          tra, gz, p, ph, h, hp, lv, cpn, th, ep, clw, m, tp, mp, rp, up, vp, trap, &
     2187          wt, water, evap, b, ment, qent, uent, vent, nent, elij, traent, sig, tv, &
     2188          tvp, iflag, precip, vprecip, ft, fr, fu, fv, ftra, upwd, dnwd, dnwd0, ma, &
     2189          mike, tls, tps, qcondc, wd)
     2190    USE conema3_mod_h
     2191    USE cvflag_mod_h
     2192    USE cvthermo_mod_h
     2193
     2194    IMPLICIT NONE
     2195
     2196    ! inputs:
     2197    INTEGER ncum, nd, na, ntra, nloc
     2198    INTEGER icb(nloc), inb(nloc)
     2199    REAL delt
     2200    REAL t(nloc, nd), rr(nloc, nd), u(nloc, nd), v(nloc, nd)
     2201    REAL tra(nloc, nd, ntra), sig(nloc, nd)
     2202    REAL gz(nloc, na), ph(nloc, nd + 1), h(nloc, na), hp(nloc, na)
     2203    REAL th(nloc, na), p(nloc, nd), tp(nloc, na)
     2204    REAL lv(nloc, na), cpn(nloc, na), ep(nloc, na), clw(nloc, na)
     2205    REAL m(nloc, na), mp(nloc, na), rp(nloc, na), up(nloc, na)
     2206    REAL vp(nloc, na), wt(nloc, nd), trap(nloc, nd, ntra)
     2207    REAL water(nloc, na), evap(nloc, na), b(nloc, na)
     2208    REAL ment(nloc, na, na), qent(nloc, na, na), uent(nloc, na, na)
     2209    ! ym      real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
     2210    REAL vent(nloc, na, na), elij(nloc, na, na)
     2211    INTEGER nent(nloc, na)
     2212    REAL traent(nloc, na, na, ntra)
     2213    REAL tv(nloc, nd), tvp(nloc, nd)
     2214
     2215    ! input/output:
     2216    INTEGER iflag(nloc)
     2217
     2218    ! outputs:
     2219    REAL precip(nloc)
     2220    REAL vprecip(nloc, nd + 1)
     2221    REAL ft(nloc, nd), fr(nloc, nd), fu(nloc, nd), fv(nloc, nd)
     2222    REAL ftra(nloc, nd, ntra)
     2223    REAL upwd(nloc, nd), dnwd(nloc, nd), ma(nloc, nd)
     2224    REAL dnwd0(nloc, nd), mike(nloc, nd)
     2225    REAL tls(nloc, nd), tps(nloc, nd)
     2226    REAL qcondc(nloc, nd) ! cld
     2227    REAL wd(nloc) ! gust
     2228
     2229    ! local variables:
     2230    INTEGER i, k, il, n, j, num1
     2231    REAL rat, awat, delti
     2232    REAL ax, bx, cx, dx, ex
     2233    REAL cpinv, rdcp, dpinv
     2234    REAL lvcp(nloc, na), mke(nloc, na)
     2235    REAL am(nloc), work(nloc), ad(nloc), amp1(nloc)
     2236    ! !!      real up1(nloc), dn1(nloc)
     2237    REAL up1(nloc, nd, nd), dn1(nloc, nd, nd)
     2238    REAL asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
     2239    REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
     2240    REAL siga(nloc, nd), sax(nloc, nd), mac(nloc, nd) ! cld
     2241
     2242
     2243    ! -------------------------------------------------------------
     2244
     2245    ! initialization:
     2246
     2247    delti = 1.0 / delt
     2248
     2249    DO il = 1, ncum
     2250      precip(il) = 0.0
     2251      wd(il) = 0.0 ! gust
     2252      vprecip(il, nd + 1) = 0.
     2253    END DO
     2254
     2255    DO i = 1, nd
     2256      DO il = 1, ncum
     2257        vprecip(il, i) = 0.0
     2258        ft(il, i) = 0.0
     2259        fr(il, i) = 0.0
     2260        fu(il, i) = 0.0
     2261        fv(il, i) = 0.0
     2262        qcondc(il, i) = 0.0 ! cld
     2263        qcond(il, i) = 0.0 ! cld
     2264        nqcond(il, i) = 0.0 ! cld
    26402265      END DO
    26412266    END DO
    26422267
    26432268    ! do j=1,ntra
    2644     ! do k=i,nl+1
     2269    ! do i=1,nd
    26452270    ! do il=1,ncum
    2646     ! if (i.le.inb(il) .and. k.le.inb(il)) then
    2647     ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
    2648     ! cpinv=1.0/cpn(il,i)
    2649     ! if (cvflag_grav) then
    2650     ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
    2651     ! :         *(traent(il,k,i,j)-tra(il,i,j))
    2652     ! else
    2653     ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
    2654     ! :             *(traent(il,k,i,j)-tra(il,i,j))
    2655     ! endif
    2656     ! endif ! i and k
     2271    ! ftra(il,i,j)=0.0
    26572272    ! enddo
    26582273    ! enddo
    26592274    ! enddo
    26602275
     2276    DO i = 1, nl
     2277      DO il = 1, ncum
     2278        lvcp(il, i) = lv(il, i) / cpn(il, i)
     2279      END DO
     2280    END DO
     2281
     2282
     2283
     2284    ! ***  calculate surface precipitation in mm/day     ***
     2285
    26612286    DO il = 1, ncum
    2662       IF (i<=inb(il)) THEN
    2663         dpinv = 1.0/(ph(il,i)-ph(il,i+1))
    2664         cpinv = 1.0/cpn(il, i)
    2665 
     2287      IF (ep(il, inb(il))>=0.0001) THEN
    26662288        IF (cvflag_grav) THEN
    2667           ! sb: on ne fait pas encore la correction permettant de mieux
    2668           ! conserver l'eau:
    2669           fr(il, i) = fr(il, i) + 0.5*sigd*(evap(il,i)+evap(il,i+1)) + &
    2670             0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)*(rp(il, &
    2671             i)-rr(il,i-1)))*dpinv
    2672 
    2673           fu(il, i) = fu(il, i) + 0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il, &
    2674             i))-mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
    2675           fv(il, i) = fv(il, i) + 0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il, &
    2676             i))-mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
    2677         ELSE ! cvflag_grav
    2678           fr(il, i) = fr(il, i) + 0.5*sigd*(evap(il,i)+evap(il,i+1)) + &
    2679             0.1*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)*(rp(il,i)-rr(il, &
    2680             i-1)))*dpinv
    2681           fu(il, i) = fu(il, i) + 0.1*(mp(il,i+1)*(up(il,i+1)-u(il, &
    2682             i))-mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
    2683           fv(il, i) = fv(il, i) + 0.1*(mp(il,i+1)*(vp(il,i+1)-v(il, &
    2684             i))-mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
    2685         END IF ! cvflag_grav
    2686 
    2687       END IF ! i
    2688     END DO
    2689 
    2690     ! sb: interface with the cloud parameterization:          ! cld
    2691 
    2692     DO k = i + 1, nl
     2289          precip(il) = wt(il, 1) * sigd * water(il, 1) * 86400. * 1000. / (rowl * grav)
     2290        ELSE
     2291          precip(il) = wt(il, 1) * sigd * water(il, 1) * 8640.
     2292        END IF
     2293      END IF
     2294    END DO
     2295
     2296    ! ***  CALCULATE VERTICAL PROFILE OF  PRECIPITATIONs IN kg/m2/s  ===
     2297
     2298    ! MAF rajout pour lessivage
     2299    DO k = 1, nl
    26932300      DO il = 1, ncum
    2694         IF (k<=inb(il) .AND. i<=inb(il)) THEN ! cld
    2695           ! (saturated downdrafts resulting from mixing)            ! cld
    2696           qcond(il, i) = qcond(il, i) + elij(il, k, i) ! cld
     2301        IF (k<=inb(il)) THEN
     2302          IF (cvflag_grav) THEN
     2303            vprecip(il, k) = wt(il, k) * sigd * water(il, k) / grav
     2304          ELSE
     2305            vprecip(il, k) = wt(il, k) * sigd * water(il, k) / 10.
     2306          END IF
     2307        END IF
     2308      END DO
     2309    END DO
     2310
     2311
     2312    ! ***  Calculate downdraft velocity scale    ***
     2313    ! ***  NE PAS UTILISER POUR L'INSTANT ***
     2314
     2315    !      do il=1,ncum
     2316    !        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
     2317    !     :                                  /(sigd*p(il,icb(il)))
     2318    !      enddo
     2319
     2320
     2321    ! ***  calculate tendencies of lowest level potential temperature  ***
     2322    ! ***                      and mixing ratio                        ***
     2323
     2324    DO il = 1, ncum
     2325      work(il) = 1.0 / (ph(il, 1) - ph(il, 2))
     2326      am(il) = 0.0
     2327    END DO
     2328
     2329    DO k = 2, nl
     2330      DO il = 1, ncum
     2331        IF (k<=inb(il)) THEN
     2332          am(il) = am(il) + m(il, k)
     2333        END IF
     2334      END DO
     2335    END DO
     2336
     2337    DO il = 1, ncum
     2338
     2339      ! convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
     2340      IF (cvflag_grav) THEN
     2341        IF ((0.01 * grav * work(il) * am(il))>=delti) iflag(il) = 1 !consist vect
     2342        ft(il, 1) = 0.01 * grav * work(il) * am(il) * (t(il, 2) - t(il, 1) + (gz(il, 2) - gz(il, &
     2343                1)) / cpn(il, 1))
     2344      ELSE
     2345        IF ((0.1 * work(il) * am(il))>=delti) iflag(il) = 1 !consistency vect
     2346        ft(il, 1) = 0.1 * work(il) * am(il) * (t(il, 2) - t(il, 1) + (gz(il, 2) - gz(il, &
     2347                1)) / cpn(il, 1))
     2348      END IF
     2349
     2350      ft(il, 1) = ft(il, 1) - 0.5 * lvcp(il, 1) * sigd * (evap(il, 1) + evap(il, 2))
     2351
     2352      IF (cvflag_grav) THEN
     2353        ft(il, 1) = ft(il, 1) - 0.009 * grav * sigd * mp(il, 2) * t(il, 1) * b(il, 1) * &
     2354                work(il)
     2355      ELSE
     2356        ft(il, 1) = ft(il, 1) - 0.09 * sigd * mp(il, 2) * t(il, 1) * b(il, 1) * work(il)
     2357      END IF
     2358
     2359      ft(il, 1) = ft(il, 1) + 0.01 * sigd * wt(il, 1) * (cl - cpd) * water(il, 2) * (t(il, 2 &
     2360              ) - t(il, 1)) * work(il) / cpn(il, 1)
     2361
     2362      IF (cvflag_grav) THEN
     2363        ! jyg1  Correction pour mieux conserver l'eau (conformite avec
     2364        ! CONVECT4.3)
     2365        ! (sb: pour l'instant, on ne fait que le chgt concernant grav, pas
     2366        ! evap)
     2367        fr(il, 1) = 0.01 * grav * mp(il, 2) * (rp(il, 2) - rr(il, 1)) * work(il) + &
     2368                sigd * 0.5 * (evap(il, 1) + evap(il, 2))
     2369        ! +tard     :          +sigd*evap(il,1)
     2370
     2371        fr(il, 1) = fr(il, 1) + 0.01 * grav * am(il) * (rr(il, 2) - rr(il, 1)) * work(il)
     2372
     2373        fu(il, 1) = fu(il, 1) + 0.01 * grav * work(il) * (mp(il, 2) * (up(il, 2) - u(il, &
     2374                1)) + am(il) * (u(il, 2) - u(il, 1)))
     2375        fv(il, 1) = fv(il, 1) + 0.01 * grav * work(il) * (mp(il, 2) * (vp(il, 2) - v(il, &
     2376                1)) + am(il) * (v(il, 2) - v(il, 1)))
     2377      ELSE ! cvflag_grav
     2378        fr(il, 1) = 0.1 * mp(il, 2) * (rp(il, 2) - rr(il, 1)) * work(il) + &
     2379                sigd * 0.5 * (evap(il, 1) + evap(il, 2))
     2380        fr(il, 1) = fr(il, 1) + 0.1 * am(il) * (rr(il, 2) - rr(il, 1)) * work(il)
     2381        fu(il, 1) = fu(il, 1) + 0.1 * work(il) * (mp(il, 2) * (up(il, 2) - u(il, &
     2382                1)) + am(il) * (u(il, 2) - u(il, 1)))
     2383        fv(il, 1) = fv(il, 1) + 0.1 * work(il) * (mp(il, 2) * (vp(il, 2) - v(il, &
     2384                1)) + am(il) * (v(il, 2) - v(il, 1)))
     2385      END IF ! cvflag_grav
     2386
     2387    END DO ! il
     2388
     2389    ! do j=1,ntra
     2390    ! do il=1,ncum
     2391    ! if (cvflag_grav) THEN
     2392    ! ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
     2393    ! :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
     2394    ! :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
     2395    ! else
     2396    ! ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
     2397    ! :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
     2398    ! :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
     2399    ! END IF
     2400    ! enddo
     2401    ! enddo
     2402
     2403    DO j = 2, nl
     2404      DO il = 1, ncum
     2405        IF (j<=inb(il)) THEN
     2406          IF (cvflag_grav) THEN
     2407            fr(il, 1) = fr(il, 1) + 0.01 * grav * work(il) * ment(il, j, 1) * (qent(il, &
     2408                    j, 1) - rr(il, 1))
     2409            fu(il, 1) = fu(il, 1) + 0.01 * grav * work(il) * ment(il, j, 1) * (uent(il, &
     2410                    j, 1) - u(il, 1))
     2411            fv(il, 1) = fv(il, 1) + 0.01 * grav * work(il) * ment(il, j, 1) * (vent(il, &
     2412                    j, 1) - v(il, 1))
     2413          ELSE ! cvflag_grav
     2414            fr(il, 1) = fr(il, 1) + 0.1 * work(il) * ment(il, j, 1) * (qent(il, j, 1) - &
     2415                    rr(il, 1))
     2416            fu(il, 1) = fu(il, 1) + 0.1 * work(il) * ment(il, j, 1) * (uent(il, j, 1) - u &
     2417                    (il, 1))
     2418            fv(il, 1) = fv(il, 1) + 0.1 * work(il) * ment(il, j, 1) * (vent(il, j, 1) - v &
     2419                    (il, 1))
     2420          END IF ! cvflag_grav
     2421        END IF ! j
     2422      END DO
     2423    END DO
     2424
     2425    ! do k=1,ntra
     2426    ! do j=2,nl
     2427    ! do il=1,ncum
     2428    ! if (j.le.inb(il)) THEN
     2429    ! if (cvflag_grav) THEN
     2430    ! ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
     2431    ! :                *(traent(il,j,1,k)-tra(il,1,k))
     2432    ! else
     2433    ! ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
     2434    ! :                *(traent(il,j,1,k)-tra(il,1,k))
     2435    ! END IF
     2436
     2437    ! END IF
     2438    ! enddo
     2439    ! enddo
     2440    ! enddo
     2441
     2442
     2443    ! ***  calculate tendencies of potential temperature and mixing ratio  ***
     2444    ! ***               at levels above the lowest level                   ***
     2445
     2446    ! ***  first find the net saturated updraft and downdraft mass fluxes  ***
     2447    ! ***                      through each level                          ***
     2448
     2449    DO i = 2, nl + 1 ! newvecto: mettre nl au lieu nl+1?
     2450
     2451      num1 = 0
     2452      DO il = 1, ncum
     2453        IF (i<=inb(il)) num1 = num1 + 1
     2454      END DO
     2455      IF (num1<=0) GO TO 500
     2456
     2457      CALL zilch(amp1, ncum)
     2458      CALL zilch(ad, ncum)
     2459
     2460      DO k = i + 1, nl + 1
     2461        DO il = 1, ncum
     2462          IF (i<=inb(il) .AND. k<=(inb(il) + 1)) THEN
     2463            amp1(il) = amp1(il) + m(il, k)
     2464          END IF
     2465        END DO
     2466      END DO
     2467
     2468      DO k = 1, i
     2469        DO j = i + 1, nl + 1
     2470          DO il = 1, ncum
     2471            IF (i<=inb(il) .AND. j<=(inb(il) + 1)) THEN
     2472              amp1(il) = amp1(il) + ment(il, k, j)
     2473            END IF
     2474          END DO
     2475        END DO
     2476      END DO
     2477
     2478      DO k = 1, i - 1
     2479        DO j = i, nl + 1 ! newvecto: nl au lieu nl+1?
     2480          DO il = 1, ncum
     2481            IF (i<=inb(il) .AND. j<=inb(il)) THEN
     2482              ad(il) = ad(il) + ment(il, j, k)
     2483            END IF
     2484          END DO
     2485        END DO
     2486      END DO
     2487
     2488      DO il = 1, ncum
     2489        IF (i<=inb(il)) THEN
     2490          dpinv = 1.0 / (ph(il, i) - ph(il, i + 1))
     2491          cpinv = 1.0 / cpn(il, i)
     2492
     2493          ! convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
     2494          IF (cvflag_grav) THEN
     2495            IF ((0.01 * grav * dpinv * amp1(il))>=delti) iflag(il) = 1 ! vecto
     2496          ELSE
     2497            IF ((0.1 * dpinv * amp1(il))>=delti) iflag(il) = 1 ! vecto
     2498          END IF
     2499
     2500          IF (cvflag_grav) THEN
     2501            ft(il, i) = 0.01 * grav * dpinv * (amp1(il) * (t(il, i + 1) - t(il, &
     2502                    i) + (gz(il, i + 1) - gz(il, i)) * cpinv) - ad(il) * (t(il, i) - t(il, &
     2503                    i - 1) + (gz(il, i) - gz(il, i - 1)) * cpinv)) - 0.5 * sigd * lvcp(il, i) * (evap(&
     2504                    il, i) + evap(il, i + 1))
     2505            rat = cpn(il, i - 1) * cpinv
     2506            ft(il, i) = ft(il, i) - 0.009 * grav * sigd * (mp(il, i + 1) * t(il, i) * b(il, i) &
     2507                    - mp(il, i) * t(il, i - 1) * rat * b(il, i - 1)) * dpinv
     2508            ft(il, i) = ft(il, i) + 0.01 * grav * dpinv * ment(il, i, i) * (hp(il, i) - h(&
     2509                    il, i) + t(il, i) * (cpv - cpd) * (rr(il, i) - qent(il, i, i))) * cpinv
     2510          ELSE ! cvflag_grav
     2511            ft(il, i) = 0.1 * dpinv * (amp1(il) * (t(il, i + 1) - t(il, &
     2512                    i) + (gz(il, i + 1) - gz(il, i)) * cpinv) - ad(il) * (t(il, i) - t(il, &
     2513                    i - 1) + (gz(il, i) - gz(il, i - 1)) * cpinv)) - 0.5 * sigd * lvcp(il, i) * (evap(&
     2514                    il, i) + evap(il, i + 1))
     2515            rat = cpn(il, i - 1) * cpinv
     2516            ft(il, i) = ft(il, i) - 0.09 * sigd * (mp(il, i + 1) * t(il, i) * b(il, i) - mp(il &
     2517                    , i) * t(il, i - 1) * rat * b(il, i - 1)) * dpinv
     2518            ft(il, i) = ft(il, i) + 0.1 * dpinv * ment(il, i, i) * (hp(il, i) - h(il, i) + &
     2519                    t(il, i) * (cpv - cpd) * (rr(il, i) - qent(il, i, i))) * cpinv
     2520          END IF ! cvflag_grav
     2521
     2522          ft(il, i) = ft(il, i) + 0.01 * sigd * wt(il, i) * (cl - cpd) * water(il, i + 1) * (&
     2523                  t(il, i + 1) - t(il, i)) * dpinv * cpinv
     2524
     2525          IF (cvflag_grav) THEN
     2526            fr(il, i) = 0.01 * grav * dpinv * (amp1(il) * (rr(il, i + 1) - rr(il, &
     2527                    i)) - ad(il) * (rr(il, i) - rr(il, i - 1)))
     2528            fu(il, i) = fu(il, i) + 0.01 * grav * dpinv * (amp1(il) * (u(il, i + 1) - u(il, &
     2529                    i)) - ad(il) * (u(il, i) - u(il, i - 1)))
     2530            fv(il, i) = fv(il, i) + 0.01 * grav * dpinv * (amp1(il) * (v(il, i + 1) - v(il, &
     2531                    i)) - ad(il) * (v(il, i) - v(il, i - 1)))
     2532          ELSE ! cvflag_grav
     2533            fr(il, i) = 0.1 * dpinv * (amp1(il) * (rr(il, i + 1) - rr(il, &
     2534                    i)) - ad(il) * (rr(il, i) - rr(il, i - 1)))
     2535            fu(il, i) = fu(il, i) + 0.1 * dpinv * (amp1(il) * (u(il, i + 1) - u(il, &
     2536                    i)) - ad(il) * (u(il, i) - u(il, i - 1)))
     2537            fv(il, i) = fv(il, i) + 0.1 * dpinv * (amp1(il) * (v(il, i + 1) - v(il, &
     2538                    i)) - ad(il) * (v(il, i) - v(il, i - 1)))
     2539          END IF ! cvflag_grav
     2540
     2541        END IF ! i
     2542      END DO
     2543
     2544      ! do k=1,ntra
     2545      ! do il=1,ncum
     2546      ! if (i.le.inb(il)) THEN
     2547      ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
     2548      ! cpinv=1.0/cpn(il,i)
     2549      ! if (cvflag_grav) THEN
     2550      ! ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
     2551      ! :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
     2552      ! :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
     2553      ! else
     2554      ! ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
     2555      ! :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
     2556      ! :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
     2557      ! END IF
     2558      ! END IF
     2559      ! enddo
     2560      ! enddo
     2561
     2562      DO k = 1, i - 1
     2563        DO il = 1, ncum
     2564          IF (i<=inb(il)) THEN
     2565            dpinv = 1.0 / (ph(il, i) - ph(il, i + 1))
     2566            cpinv = 1.0 / cpn(il, i)
     2567
     2568            awat = elij(il, k, i) - (1. - ep(il, i)) * clw(il, i)
     2569            awat = amax1(awat, 0.0)
     2570
     2571            IF (cvflag_grav) THEN
     2572              fr(il, i) = fr(il, i) + 0.01 * grav * dpinv * ment(il, k, i) * (qent(il, k &
     2573                      , i) - awat - rr(il, i))
     2574              fu(il, i) = fu(il, i) + 0.01 * grav * dpinv * ment(il, k, i) * (uent(il, k &
     2575                      , i) - u(il, i))
     2576              fv(il, i) = fv(il, i) + 0.01 * grav * dpinv * ment(il, k, i) * (vent(il, k &
     2577                      , i) - v(il, i))
     2578            ELSE ! cvflag_grav
     2579              fr(il, i) = fr(il, i) + 0.1 * dpinv * ment(il, k, i) * (qent(il, k, i) - &
     2580                      awat - rr(il, i))
     2581              fu(il, i) = fu(il, i) + 0.01 * grav * dpinv * ment(il, k, i) * (uent(il, k &
     2582                      , i) - u(il, i))
     2583              fv(il, i) = fv(il, i) + 0.1 * dpinv * ment(il, k, i) * (vent(il, k, i) - v(&
     2584                      il, i))
     2585            END IF ! cvflag_grav
     2586
     2587            ! (saturated updrafts resulting from mixing)        ! cld
     2588            qcond(il, i) = qcond(il, i) + (elij(il, k, i) - awat) ! cld
     2589            nqcond(il, i) = nqcond(il, i) + 1. ! cld
     2590          END IF ! i
     2591        END DO
     2592      END DO
     2593
     2594      ! do j=1,ntra
     2595      ! do k=1,i-1
     2596      ! do il=1,ncum
     2597      ! if (i.le.inb(il)) THEN
     2598      ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
     2599      ! cpinv=1.0/cpn(il,i)
     2600      ! if (cvflag_grav) THEN
     2601      ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
     2602      ! :        *(traent(il,k,i,j)-tra(il,i,j))
     2603      ! else
     2604      ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
     2605      ! :        *(traent(il,k,i,j)-tra(il,i,j))
     2606      ! END IF
     2607      ! END IF
     2608      ! enddo
     2609      ! enddo
     2610      ! enddo
     2611
     2612      DO k = i, nl + 1
     2613        DO il = 1, ncum
     2614          IF (i<=inb(il) .AND. k<=inb(il)) THEN
     2615            dpinv = 1.0 / (ph(il, i) - ph(il, i + 1))
     2616            cpinv = 1.0 / cpn(il, i)
     2617
     2618            IF (cvflag_grav) THEN
     2619              fr(il, i) = fr(il, i) + 0.01 * grav * dpinv * ment(il, k, i) * (qent(il, k &
     2620                      , i) - rr(il, i))
     2621              fu(il, i) = fu(il, i) + 0.01 * grav * dpinv * ment(il, k, i) * (uent(il, k &
     2622                      , i) - u(il, i))
     2623              fv(il, i) = fv(il, i) + 0.01 * grav * dpinv * ment(il, k, i) * (vent(il, k &
     2624                      , i) - v(il, i))
     2625            ELSE ! cvflag_grav
     2626              fr(il, i) = fr(il, i) + 0.1 * dpinv * ment(il, k, i) * (qent(il, k, i) - rr &
     2627                      (il, i))
     2628              fu(il, i) = fu(il, i) + 0.1 * dpinv * ment(il, k, i) * (uent(il, k, i) - u(&
     2629                      il, i))
     2630              fv(il, i) = fv(il, i) + 0.1 * dpinv * ment(il, k, i) * (vent(il, k, i) - v(&
     2631                      il, i))
     2632            END IF ! cvflag_grav
     2633          END IF ! i and k
     2634        END DO
     2635      END DO
     2636
     2637      ! do j=1,ntra
     2638      ! do k=i,nl+1
     2639      ! do il=1,ncum
     2640      ! if (i.le.inb(il) .AND. k.le.inb(il)) THEN
     2641      ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
     2642      ! cpinv=1.0/cpn(il,i)
     2643      ! if (cvflag_grav) THEN
     2644      ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
     2645      ! :         *(traent(il,k,i,j)-tra(il,i,j))
     2646      ! else
     2647      ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
     2648      ! :             *(traent(il,k,i,j)-tra(il,i,j))
     2649      ! END IF
     2650      ! END IF ! i and k
     2651      ! enddo
     2652      ! enddo
     2653      ! enddo
     2654
     2655      DO il = 1, ncum
     2656        IF (i<=inb(il)) THEN
     2657          dpinv = 1.0 / (ph(il, i) - ph(il, i + 1))
     2658          cpinv = 1.0 / cpn(il, i)
     2659
     2660          IF (cvflag_grav) THEN
     2661            ! sb: on ne fait pas encore la correction permettant de mieux
     2662            ! conserver l'eau:
     2663            fr(il, i) = fr(il, i) + 0.5 * sigd * (evap(il, i) + evap(il, i + 1)) + &
     2664                    0.01 * grav * (mp(il, i + 1) * (rp(il, i + 1) - rr(il, i)) - mp(il, i) * (rp(il, &
     2665                            i) - rr(il, i - 1))) * dpinv
     2666
     2667            fu(il, i) = fu(il, i) + 0.01 * grav * (mp(il, i + 1) * (up(il, i + 1) - u(il, &
     2668                    i)) - mp(il, i) * (up(il, i) - u(il, i - 1))) * dpinv
     2669            fv(il, i) = fv(il, i) + 0.01 * grav * (mp(il, i + 1) * (vp(il, i + 1) - v(il, &
     2670                    i)) - mp(il, i) * (vp(il, i) - v(il, i - 1))) * dpinv
     2671          ELSE ! cvflag_grav
     2672            fr(il, i) = fr(il, i) + 0.5 * sigd * (evap(il, i) + evap(il, i + 1)) + &
     2673                    0.1 * (mp(il, i + 1) * (rp(il, i + 1) - rr(il, i)) - mp(il, i) * (rp(il, i) - rr(il, &
     2674                            i - 1))) * dpinv
     2675            fu(il, i) = fu(il, i) + 0.1 * (mp(il, i + 1) * (up(il, i + 1) - u(il, &
     2676                    i)) - mp(il, i) * (up(il, i) - u(il, i - 1))) * dpinv
     2677            fv(il, i) = fv(il, i) + 0.1 * (mp(il, i + 1) * (vp(il, i + 1) - v(il, &
     2678                    i)) - mp(il, i) * (vp(il, i) - v(il, i - 1))) * dpinv
     2679          END IF ! cvflag_grav
     2680
     2681        END IF ! i
     2682      END DO
     2683
     2684      ! sb: interface with the cloud parameterization:          ! cld
     2685
     2686      DO k = i + 1, nl
     2687        DO il = 1, ncum
     2688          IF (k<=inb(il) .AND. i<=inb(il)) THEN ! cld
     2689            ! (saturated downdrafts resulting from mixing)            ! cld
     2690            qcond(il, i) = qcond(il, i) + elij(il, k, i) ! cld
     2691            nqcond(il, i) = nqcond(il, i) + 1. ! cld
     2692          END IF ! cld
     2693        END DO ! cld
     2694      END DO ! cld
     2695
     2696      ! (particular case: no detraining level is found)         ! cld
     2697      DO il = 1, ncum ! cld
     2698        IF (i<=inb(il) .AND. nent(il, i)==0) THEN ! cld
     2699          qcond(il, i) = qcond(il, i) + (1. - ep(il, i)) * clw(il, i) ! cld
    26972700          nqcond(il, i) = nqcond(il, i) + 1. ! cld
    26982701        END IF ! cld
    26992702      END DO ! cld
    2700     END DO ! cld
    2701 
    2702     ! (particular case: no detraining level is found)         ! cld
    2703     DO il = 1, ncum ! cld
    2704       IF (i<=inb(il) .AND. nent(il,i)==0) THEN ! cld
    2705         qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i) ! cld
    2706         nqcond(il, i) = nqcond(il, i) + 1. ! cld
    2707       END IF ! cld
    2708     END DO ! cld
    2709 
    2710     DO il = 1, ncum ! cld
    2711       IF (i<=inb(il) .AND. nqcond(il,i)/=0.) THEN ! cld
    2712         qcond(il, i) = qcond(il, i)/nqcond(il, i) ! cld
    2713       END IF ! cld
     2703
     2704      DO il = 1, ncum ! cld
     2705        IF (i<=inb(il) .AND. nqcond(il, i)/=0.) THEN ! cld
     2706          qcond(il, i) = qcond(il, i) / nqcond(il, i) ! cld
     2707        END IF ! cld
     2708      END DO
     2709
     2710      ! do j=1,ntra
     2711      ! do il=1,ncum
     2712      ! if (i.le.inb(il)) THEN
     2713      ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
     2714      ! cpinv=1.0/cpn(il,i)
     2715
     2716      ! if (cvflag_grav) THEN
     2717      ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
     2718      ! :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
     2719      ! :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
     2720      ! else
     2721      ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
     2722      ! :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
     2723      ! :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
     2724      ! END IF
     2725      ! END IF ! i
     2726      ! enddo
     2727      ! enddo
     2728
     2729    500 END DO
     2730
     2731
     2732    ! ***   move the detrainment at level inb down to level inb-1   ***
     2733    ! ***        in such a way as to preserve the vertically        ***
     2734    ! ***          integrated enthalpy and water tendencies         ***
     2735
     2736    DO il = 1, ncum
     2737
     2738      ax = 0.1 * ment(il, inb(il), inb(il)) * (hp(il, inb(il)) - h(il, inb(il)) + t(il, &
     2739              inb(il)) * (cpv - cpd) * (rr(il, inb(il)) - qent(il, inb(il), &
     2740              inb(il)))) / (cpn(il, inb(il)) * (ph(il, inb(il)) - ph(il, inb(il) + 1)))
     2741      ft(il, inb(il)) = ft(il, inb(il)) - ax
     2742      ft(il, inb(il) - 1) = ft(il, inb(il) - 1) + ax * cpn(il, inb(il)) * (ph(il, inb(il &
     2743              )) - ph(il, inb(il) + 1)) / (cpn(il, inb(il) - 1) * (ph(il, inb(il) - 1) - ph(il, &
     2744              inb(il))))
     2745
     2746      bx = 0.1 * ment(il, inb(il), inb(il)) * (qent(il, inb(il), inb(il)) - rr(il, inb(&
     2747              il))) / (ph(il, inb(il)) - ph(il, inb(il) + 1))
     2748      fr(il, inb(il)) = fr(il, inb(il)) - bx
     2749      fr(il, inb(il) - 1) = fr(il, inb(il) - 1) + bx * (ph(il, inb(il)) - ph(il, inb(il) + &
     2750              1)) / (ph(il, inb(il) - 1) - ph(il, inb(il)))
     2751
     2752      cx = 0.1 * ment(il, inb(il), inb(il)) * (uent(il, inb(il), inb(il)) - u(il, inb(il &
     2753              ))) / (ph(il, inb(il)) - ph(il, inb(il) + 1))
     2754      fu(il, inb(il)) = fu(il, inb(il)) - cx
     2755      fu(il, inb(il) - 1) = fu(il, inb(il) - 1) + cx * (ph(il, inb(il)) - ph(il, inb(il) + &
     2756              1)) / (ph(il, inb(il) - 1) - ph(il, inb(il)))
     2757
     2758      dx = 0.1 * ment(il, inb(il), inb(il)) * (vent(il, inb(il), inb(il)) - v(il, inb(il &
     2759              ))) / (ph(il, inb(il)) - ph(il, inb(il) + 1))
     2760      fv(il, inb(il)) = fv(il, inb(il)) - dx
     2761      fv(il, inb(il) - 1) = fv(il, inb(il) - 1) + dx * (ph(il, inb(il)) - ph(il, inb(il) + &
     2762              1)) / (ph(il, inb(il) - 1) - ph(il, inb(il)))
     2763
    27142764    END DO
    27152765
    27162766    ! do j=1,ntra
    27172767    ! do il=1,ncum
    2718     ! if (i.le.inb(il)) then
    2719     ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
    2720     ! cpinv=1.0/cpn(il,i)
    2721 
    2722     ! if (cvflag_grav) then
    2723     ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
    2724     ! :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
    2725     ! :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
    2726     ! else
    2727     ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
    2728     ! :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
    2729     ! :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
    2730     ! endif
    2731     ! endif ! i
     2768    ! ex=0.1*ment(il,inb(il),inb(il))
     2769    ! :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
     2770    ! :      /(ph(il,inb(il))-ph(il,inb(il)+1))
     2771    ! ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
     2772    ! ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
     2773    ! :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
     2774    ! :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
    27322775    ! enddo
    27332776    ! enddo
    27342777
    2735 500 END DO
    2736 
    2737 
    2738   ! ***   move the detrainment at level inb down to level inb-1   ***
    2739   ! ***        in such a way as to preserve the vertically        ***
    2740   ! ***          integrated enthalpy and water tendencies         ***
    2741 
    2742   DO il = 1, ncum
    2743 
    2744     ax = 0.1*ment(il, inb(il), inb(il))*(hp(il,inb(il))-h(il,inb(il))+t(il, &
    2745       inb(il))*(cpv-cpd)*(rr(il,inb(il))-qent(il,inb(il), &
    2746       inb(il))))/(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
    2747     ft(il, inb(il)) = ft(il, inb(il)) - ax
    2748     ft(il, inb(il)-1) = ft(il, inb(il)-1) + ax*cpn(il, inb(il))*(ph(il,inb(il &
    2749       ))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il, &
    2750       inb(il))))
    2751 
    2752     bx = 0.1*ment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))-rr(il,inb( &
    2753       il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
    2754     fr(il, inb(il)) = fr(il, inb(il)) - bx
    2755     fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+ &
    2756       1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
    2757 
    2758     cx = 0.1*ment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u(il,inb(il &
    2759       )))/(ph(il,inb(il))-ph(il,inb(il)+1))
    2760     fu(il, inb(il)) = fu(il, inb(il)) - cx
    2761     fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+ &
    2762       1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
    2763 
    2764     dx = 0.1*ment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v(il,inb(il &
    2765       )))/(ph(il,inb(il))-ph(il,inb(il)+1))
    2766     fv(il, inb(il)) = fv(il, inb(il)) - dx
    2767     fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+ &
    2768       1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
    2769 
    2770   END DO
    2771 
    2772   ! do j=1,ntra
    2773   ! do il=1,ncum
    2774   ! ex=0.1*ment(il,inb(il),inb(il))
    2775   ! :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
    2776   ! :      /(ph(il,inb(il))-ph(il,inb(il)+1))
    2777   ! ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
    2778   ! ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
    2779   ! :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
    2780   ! :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
    2781   ! enddo
    2782   ! enddo
    2783 
    2784 
    2785   ! ***    homoginize tendencies below cloud base    ***
    2786 
    2787 
    2788   DO il = 1, ncum
    2789     asum(il) = 0.0
    2790     bsum(il) = 0.0
    2791     csum(il) = 0.0
    2792     dsum(il) = 0.0
    2793   END DO
    2794 
    2795   DO i = 1, nl
     2778
     2779    ! ***    homoginize tendencies below cloud base    ***
     2780
    27962781    DO il = 1, ncum
    2797       IF (i<=(icb(il)-1)) THEN
    2798         asum(il) = asum(il) + ft(il, i)*(ph(il,i)-ph(il,i+1))
    2799         bsum(il) = bsum(il) + fr(il, i)*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il, &
    2800           1)))*(ph(il,i)-ph(il,i+1))
    2801         csum(il) = csum(il) + (lv(il,i)+(cl-cpd)*(t(il,i)-t(il, &
    2802           1)))*(ph(il,i)-ph(il,i+1))
    2803         dsum(il) = dsum(il) + t(il, i)*(ph(il,i)-ph(il,i+1))/th(il, i)
    2804       END IF
    2805     END DO
    2806   END DO
    2807 
    2808   ! !!!      do 700 i=1,icb(il)-1
    2809   DO i = 1, nl
     2782      asum(il) = 0.0
     2783      bsum(il) = 0.0
     2784      csum(il) = 0.0
     2785      dsum(il) = 0.0
     2786    END DO
     2787
     2788    DO i = 1, nl
     2789      DO il = 1, ncum
     2790        IF (i<=(icb(il) - 1)) THEN
     2791          asum(il) = asum(il) + ft(il, i) * (ph(il, i) - ph(il, i + 1))
     2792          bsum(il) = bsum(il) + fr(il, i) * (lv(il, i) + (cl - cpd) * (t(il, i) - t(il, &
     2793                  1))) * (ph(il, i) - ph(il, i + 1))
     2794          csum(il) = csum(il) + (lv(il, i) + (cl - cpd) * (t(il, i) - t(il, &
     2795                  1))) * (ph(il, i) - ph(il, i + 1))
     2796          dsum(il) = dsum(il) + t(il, i) * (ph(il, i) - ph(il, i + 1)) / th(il, i)
     2797        END IF
     2798      END DO
     2799    END DO
     2800
     2801    ! !!!      do 700 i=1,icb(il)-1
     2802    DO i = 1, nl
     2803      DO il = 1, ncum
     2804        IF (i<=(icb(il) - 1)) THEN
     2805          ft(il, i) = asum(il) * t(il, i) / (th(il, i) * dsum(il))
     2806          fr(il, i) = bsum(il) / csum(il)
     2807        END IF
     2808      END DO
     2809    END DO
     2810
     2811
     2812    ! ***           reset counter and return           ***
     2813
    28102814    DO il = 1, ncum
    2811       IF (i<=(icb(il)-1)) THEN
    2812         ft(il, i) = asum(il)*t(il, i)/(th(il,i)*dsum(il))
    2813         fr(il, i) = bsum(il)/csum(il)
    2814       END IF
    2815     END DO
    2816   END DO
    2817 
    2818 
    2819   ! ***           reset counter and return           ***
    2820 
    2821   DO il = 1, ncum
    2822     sig(il, nd) = 2.0
    2823   END DO
    2824 
    2825 
    2826   DO i = 1, nd
    2827     DO il = 1, ncum
    2828       upwd(il, i) = 0.0
    2829       dnwd(il, i) = 0.0
    2830     END DO
    2831   END DO
    2832 
    2833   DO i = 1, nl
    2834     DO il = 1, ncum
    2835       dnwd0(il, i) = -mp(il, i)
    2836     END DO
    2837   END DO
    2838   DO i = nl + 1, nd
    2839     DO il = 1, ncum
    2840       dnwd0(il, i) = 0.
    2841     END DO
    2842   END DO
    2843 
    2844 
    2845   DO i = 1, nl
    2846     DO il = 1, ncum
    2847       IF (i>=icb(il) .AND. i<=inb(il)) THEN
     2815      sig(il, nd) = 2.0
     2816    END DO
     2817
     2818    DO i = 1, nd
     2819      DO il = 1, ncum
    28482820        upwd(il, i) = 0.0
    28492821        dnwd(il, i) = 0.0
    2850       END IF
    2851     END DO
    2852   END DO
    2853 
    2854   DO i = 1, nl
    2855     DO k = 1, nl
     2822      END DO
     2823    END DO
     2824
     2825    DO i = 1, nl
    28562826      DO il = 1, ncum
    2857         up1(il, k, i) = 0.0
    2858         dn1(il, k, i) = 0.0
    2859       END DO
    2860     END DO
    2861   END DO
    2862 
    2863   DO i = 1, nl
    2864     DO k = i, nl
    2865       DO n = 1, i - 1
     2827        dnwd0(il, i) = -mp(il, i)
     2828      END DO
     2829    END DO
     2830    DO i = nl + 1, nd
     2831      DO il = 1, ncum
     2832        dnwd0(il, i) = 0.
     2833      END DO
     2834    END DO
     2835
     2836    DO i = 1, nl
     2837      DO il = 1, ncum
     2838        IF (i>=icb(il) .AND. i<=inb(il)) THEN
     2839          upwd(il, i) = 0.0
     2840          dnwd(il, i) = 0.0
     2841        END IF
     2842      END DO
     2843    END DO
     2844
     2845    DO i = 1, nl
     2846      DO k = 1, nl
    28662847        DO il = 1, ncum
    2867           IF (i>=icb(il) .AND. i<=inb(il) .AND. k<=inb(il)) THEN
    2868             up1(il, k, i) = up1(il, k, i) + ment(il, n, k)
    2869             dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n)
     2848          up1(il, k, i) = 0.0
     2849          dn1(il, k, i) = 0.0
     2850        END DO
     2851      END DO
     2852    END DO
     2853
     2854    DO i = 1, nl
     2855      DO k = i, nl
     2856        DO n = 1, i - 1
     2857          DO il = 1, ncum
     2858            IF (i>=icb(il) .AND. i<=inb(il) .AND. k<=inb(il)) THEN
     2859              up1(il, k, i) = up1(il, k, i) + ment(il, n, k)
     2860              dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n)
     2861            END IF
     2862          END DO
     2863        END DO
     2864      END DO
     2865    END DO
     2866
     2867    DO i = 2, nl
     2868      DO k = i, nl
     2869        DO il = 1, ncum
     2870          ! test         if (i.ge.icb(il).AND.i.le.inb(il).AND.k.le.inb(il))
     2871          ! THEN
     2872          IF (i<=inb(il) .AND. k<=inb(il)) THEN
     2873            upwd(il, i) = upwd(il, i) + m(il, k) + up1(il, k, i)
     2874            dnwd(il, i) = dnwd(il, i) + dn1(il, k, i)
    28702875          END IF
    28712876        END DO
    28722877      END DO
    28732878    END DO
    2874   END DO
    2875 
    2876   DO i = 2, nl
    2877     DO k = i, nl
     2879
     2880
     2881    ! !!!      DO il=1,ncum
     2882    ! !!!      do i=icb(il),inb(il)
     2883    ! !!!
     2884    ! !!!      upwd(il,i)=0.0
     2885    ! !!!      dnwd(il,i)=0.0
     2886    ! !!!      do k=i,inb(il)
     2887    ! !!!      up1=0.0
     2888    ! !!!      dn1=0.0
     2889    ! !!!      do n=1,i-1
     2890    ! !!!      up1=up1+ment(il,n,k)
     2891    ! !!!      dn1=dn1-ment(il,k,n)
     2892    ! !!!      enddo
     2893    ! !!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
     2894    ! !!!      dnwd(il,i)=dnwd(il,i)+dn1
     2895    ! !!!      enddo
     2896    ! !!!      enddo
     2897    ! !!!
     2898    ! !!!      ENDDO
     2899
     2900    ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     2901    ! determination de la variation de flux ascendant entre
     2902    ! deux niveau non dilue mike
     2903    ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     2904
     2905    DO i = 1, nl
    28782906      DO il = 1, ncum
    2879         ! test         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il))
    2880         ! then
    2881         IF (i<=inb(il) .AND. k<=inb(il)) THEN
    2882           upwd(il, i) = upwd(il, i) + m(il, k) + up1(il, k, i)
    2883           dnwd(il, i) = dnwd(il, i) + dn1(il, k, i)
     2907        mike(il, i) = m(il, i)
     2908      END DO
     2909    END DO
     2910
     2911    DO i = nl + 1, nd
     2912      DO il = 1, ncum
     2913        mike(il, i) = 0.
     2914      END DO
     2915    END DO
     2916
     2917    DO i = 1, nd
     2918      DO il = 1, ncum
     2919        ma(il, i) = 0
     2920      END DO
     2921    END DO
     2922
     2923    DO i = 1, nl
     2924      DO j = i, nl
     2925        DO il = 1, ncum
     2926          ma(il, i) = ma(il, i) + m(il, j)
     2927        END DO
     2928      END DO
     2929    END DO
     2930
     2931    DO i = nl + 1, nd
     2932      DO il = 1, ncum
     2933        ma(il, i) = 0.
     2934      END DO
     2935    END DO
     2936
     2937    DO i = 1, nl
     2938      DO il = 1, ncum
     2939        IF (i<=(icb(il) - 1)) THEN
     2940          ma(il, i) = 0
    28842941        END IF
    28852942      END DO
    28862943    END DO
    2887   END DO
    2888 
    2889 
    2890   ! !!!      DO il=1,ncum
    2891   ! !!!      do i=icb(il),inb(il)
    2892   ! !!!
    2893   ! !!!      upwd(il,i)=0.0
    2894   ! !!!      dnwd(il,i)=0.0
    2895   ! !!!      do k=i,inb(il)
    2896   ! !!!      up1=0.0
    2897   ! !!!      dn1=0.0
    2898   ! !!!      do n=1,i-1
    2899   ! !!!      up1=up1+ment(il,n,k)
    2900   ! !!!      dn1=dn1-ment(il,k,n)
    2901   ! !!!      enddo
    2902   ! !!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
    2903   ! !!!      dnwd(il,i)=dnwd(il,i)+dn1
    2904   ! !!!      enddo
    2905   ! !!!      enddo
    2906   ! !!!
    2907   ! !!!      ENDDO
    2908 
    2909   ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    2910   ! determination de la variation de flux ascendant entre
    2911   ! deux niveau non dilue mike
    2912   ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    2913 
    2914   DO i = 1, nl
    2915     DO il = 1, ncum
    2916       mike(il, i) = m(il, i)
    2917     END DO
    2918   END DO
    2919 
    2920   DO i = nl + 1, nd
    2921     DO il = 1, ncum
    2922       mike(il, i) = 0.
    2923     END DO
    2924   END DO
    2925 
    2926   DO i = 1, nd
    2927     DO il = 1, ncum
    2928       ma(il, i) = 0
    2929     END DO
    2930   END DO
    2931 
    2932   DO i = 1, nl
    2933     DO j = i, nl
     2944
     2945    ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     2946    ! icb represente de niveau ou se trouve la
     2947    ! base du nuage , et inb le top du nuage
     2948    ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     2949
     2950    DO i = 1, nd
    29342951      DO il = 1, ncum
    2935         ma(il, i) = ma(il, i) + m(il, j)
    2936       END DO
    2937     END DO
    2938   END DO
    2939 
    2940   DO i = nl + 1, nd
    2941     DO il = 1, ncum
    2942       ma(il, i) = 0.
    2943     END DO
    2944   END DO
    2945 
    2946   DO i = 1, nl
    2947     DO il = 1, ncum
    2948       IF (i<=(icb(il)-1)) THEN
    2949         ma(il, i) = 0
    2950       END IF
    2951     END DO
    2952   END DO
    2953 
    2954   ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    2955   ! icb represente de niveau ou se trouve la
    2956   ! base du nuage , et inb le top du nuage
    2957   ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    2958 
    2959   DO i = 1, nd
    2960     DO il = 1, ncum
    2961       mke(il, i) = upwd(il, i) + dnwd(il, i)
    2962     END DO
    2963   END DO
    2964 
    2965   DO i = 1, nd
    2966     DO il = 1, ncum
    2967       rdcp = (rrd*(1.-rr(il,i))-rr(il,i)*rrv)/(cpd*(1.-rr(il, &
    2968         i))+rr(il,i)*cpv)
    2969       tls(il, i) = t(il, i)*(1000.0/p(il,i))**rdcp
    2970       tps(il, i) = tp(il, i)
    2971     END DO
    2972   END DO
    2973 
    2974 
    2975   ! *** diagnose the in-cloud mixing ratio   ***            ! cld
    2976   ! ***           of condensed water         ***            ! cld
    2977   ! ! cld
    2978 
    2979   DO i = 1, nd ! cld
    2980     DO il = 1, ncum ! cld
    2981       mac(il, i) = 0.0 ! cld
    2982       wa(il, i) = 0.0 ! cld
    2983       siga(il, i) = 0.0 ! cld
    2984       sax(il, i) = 0.0 ! cld
     2952        mke(il, i) = upwd(il, i) + dnwd(il, i)
     2953      END DO
     2954    END DO
     2955
     2956    DO i = 1, nd
     2957      DO il = 1, ncum
     2958        rdcp = (rrd * (1. - rr(il, i)) - rr(il, i) * rrv) / (cpd * (1. - rr(il, &
     2959                i)) + rr(il, i) * cpv)
     2960        tls(il, i) = t(il, i) * (1000.0 / p(il, i))**rdcp
     2961        tps(il, i) = tp(il, i)
     2962      END DO
     2963    END DO
     2964
     2965
     2966    ! *** diagnose the in-cloud mixing ratio   ***            ! cld
     2967    ! ***           of condensed water         ***            ! cld
     2968    ! cld
     2969
     2970    DO i = 1, nd ! cld
     2971      DO il = 1, ncum ! cld
     2972        mac(il, i) = 0.0 ! cld
     2973        wa(il, i) = 0.0 ! cld
     2974        siga(il, i) = 0.0 ! cld
     2975        sax(il, i) = 0.0 ! cld
     2976      END DO ! cld
    29852977    END DO ! cld
    2986   END DO ! cld
    2987 
    2988   DO i = minorig, nl ! cld
    2989     DO k = i + 1, nl + 1 ! cld
     2978
     2979    DO i = minorig, nl ! cld
     2980      DO k = i + 1, nl + 1 ! cld
     2981        DO il = 1, ncum ! cld
     2982          IF (i<=inb(il) .AND. k<=(inb(il) + 1)) THEN ! cld
     2983            mac(il, i) = mac(il, i) + m(il, k) ! cld
     2984          END IF ! cld
     2985        END DO ! cld
     2986      END DO ! cld
     2987    END DO ! cld
     2988
     2989    DO i = 1, nl ! cld
     2990      DO j = 1, i ! cld
     2991        DO il = 1, ncum ! cld
     2992          IF (i>=icb(il) .AND. i<=(inb(il) - 1) & ! cld
     2993                  .AND. j>=icb(il)) THEN ! cld
     2994            sax(il, i) = sax(il, i) + rrd * (tvp(il, j) - tv(il, j)) & ! cld
     2995                    * (ph(il, j) - ph(il, j + 1)) / p(il, j) ! cld
     2996          END IF ! cld
     2997        END DO ! cld
     2998      END DO ! cld
     2999    END DO ! cld
     3000
     3001    DO i = 1, nl ! cld
    29903002      DO il = 1, ncum ! cld
    2991         IF (i<=inb(il) .AND. k<=(inb(il)+1)) THEN ! cld
    2992           mac(il, i) = mac(il, i) + m(il, k) ! cld
     3003        IF (i>=icb(il) .AND. i<=(inb(il) - 1) & ! cld
     3004                .AND. sax(il, i)>0.0) THEN ! cld
     3005          wa(il, i) = sqrt(2. * sax(il, i)) ! cld
    29933006        END IF ! cld
    29943007      END DO ! cld
    29953008    END DO ! cld
    2996   END DO ! cld
    2997 
    2998   DO i = 1, nl ! cld
    2999     DO j = 1, i ! cld
     3009
     3010    DO i = 1, nl ! cld
    30003011      DO il = 1, ncum ! cld
    3001         IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
    3002             .AND. j>=icb(il)) THEN ! cld
    3003           sax(il, i) = sax(il, i) + rrd*(tvp(il,j)-tv(il,j)) & ! cld
    3004             *(ph(il,j)-ph(il,j+1))/p(il, j) ! cld
    3005         END IF ! cld
     3012        IF (wa(il, i)>0.0) &          ! cld
     3013                siga(il, i) = mac(il, i) / wa(il, i) & ! cld
     3014                        * rrd * tvp(il, i) / p(il, i) / 100. / delta ! cld
     3015        siga(il, i) = min(siga(il, i), 1.0) ! cld
     3016        ! IM cf. FH
     3017        IF (iflag_clw==0) THEN
     3018          qcondc(il, i) = siga(il, i) * clw(il, i) * (1. - ep(il, i)) & ! cld
     3019                  + (1. - siga(il, i)) * qcond(il, i) ! cld
     3020        ELSE IF (iflag_clw==1) THEN
     3021          qcondc(il, i) = qcond(il, i) ! cld
     3022        END IF
     3023
    30063024      END DO ! cld
    30073025    END DO ! cld
    3008   END DO ! cld
    3009 
    3010   DO i = 1, nl ! cld
    3011     DO il = 1, ncum ! cld
    3012       IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
    3013           .AND. sax(il,i)>0.0) THEN ! cld
    3014         wa(il, i) = sqrt(2.*sax(il,i)) ! cld
    3015       END IF ! cld
    3016     END DO ! cld
    3017   END DO ! cld
    3018 
    3019   DO i = 1, nl ! cld
    3020     DO il = 1, ncum ! cld
    3021       IF (wa(il,i)>0.0) &          ! cld
    3022         siga(il, i) = mac(il, i)/wa(il, i) & ! cld
    3023         *rrd*tvp(il, i)/p(il, i)/100./delta ! cld
    3024       siga(il, i) = min(siga(il,i), 1.0) ! cld
    3025       ! IM cf. FH
    3026       IF (iflag_clw==0) THEN
    3027         qcondc(il, i) = siga(il, i)*clw(il, i)*(1.-ep(il,i)) & ! cld
    3028           +(1.-siga(il,i))*qcond(il, i) ! cld
    3029       ELSE IF (iflag_clw==1) THEN
    3030         qcondc(il, i) = qcond(il, i) ! cld
    3031       END IF
    3032 
    3033     END DO ! cld
    3034   END DO ! cld
    3035 
    3036   RETURN
    3037 END SUBROUTINE cv30_yield
    3038 
    3039 ! !RomP >>>
    3040 SUBROUTINE cv30_tracer(nloc, len, ncum, nd, na, ment, sij, da, phi, phi2, &
    3041     d1a, dam, ep, vprecip, elij, clw, epmlmmm, eplamm, icb, inb)
    3042   IMPLICIT NONE
    3043 
    3044   include "cv30param.h"
    3045 
    3046   ! inputs:
    3047   INTEGER ncum, nd, na, nloc, len
    3048   REAL ment(nloc, na, na), sij(nloc, na, na)
    3049   REAL clw(nloc, nd), elij(nloc, na, na)
    3050   REAL ep(nloc, na)
    3051   INTEGER icb(nloc), inb(nloc)
    3052   REAL vprecip(nloc, nd+1)
    3053   ! ouputs:
    3054   REAL da(nloc, na), phi(nloc, na, na)
    3055   REAL phi2(nloc, na, na)
    3056   REAL d1a(nloc, na), dam(nloc, na)
    3057   REAL epmlmmm(nloc, na, na), eplamm(nloc, na)
    3058   ! variables pour tracer dans precip de l'AA et des mel
    3059   ! local variables:
    3060   INTEGER i, j, k, nam1
    3061   REAL epm(nloc, na, na)
    3062 
    3063   nam1=na-1 ! Introduced because ep is not defined for j=na
    3064   ! variables d'Emanuel : du second indice au troisieme
    3065   ! --->    tab(i,k,j) -> de l origine k a l arrivee j
    3066   ! ment, sij, elij
    3067   ! variables personnelles : du troisieme au second indice
    3068   ! --->    tab(i,j,k) -> de k a j
    3069   ! phi, phi2
    3070 
    3071   ! initialisations
    3072   DO j = 1, na
    3073     DO i = 1, ncum
    3074       da(i, j) = 0.
    3075       d1a(i, j) = 0.
    3076       dam(i, j) = 0.
    3077       eplamm(i, j) = 0.
    3078     END DO
    3079   END DO
    3080   DO k = 1, na
     3026
     3027  END SUBROUTINE cv30_yield
     3028
     3029  !RomP >>>
     3030  SUBROUTINE cv30_tracer(nloc, len, ncum, nd, na, ment, sij, da, phi, phi2, &
     3031          d1a, dam, ep, vprecip, elij, clw, epmlmmm, eplamm, icb, inb)
     3032    IMPLICIT NONE
     3033
     3034
     3035
     3036    ! inputs:
     3037    INTEGER ncum, nd, na, nloc, len
     3038    REAL ment(nloc, na, na), sij(nloc, na, na)
     3039    REAL clw(nloc, nd), elij(nloc, na, na)
     3040    REAL ep(nloc, na)
     3041    INTEGER icb(nloc), inb(nloc)
     3042    REAL vprecip(nloc, nd + 1)
     3043    ! ouputs:
     3044    REAL da(nloc, na), phi(nloc, na, na)
     3045    REAL phi2(nloc, na, na)
     3046    REAL d1a(nloc, na), dam(nloc, na)
     3047    REAL epmlmmm(nloc, na, na), eplamm(nloc, na)
     3048    ! variables pour tracer dans precip de l'AA et des mel
     3049    ! local variables:
     3050    INTEGER i, j, k, nam1
     3051    REAL epm(nloc, na, na)
     3052
     3053    nam1 = na - 1 ! Introduced because ep is not defined for j=na
     3054    ! variables d'Emanuel : du second indice au troisieme
     3055    ! --->    tab(i,k,j) -> de l origine k a l arrivee j
     3056    ! ment, sij, elij
     3057    ! variables personnelles : du troisieme au second indice
     3058    ! --->    tab(i,j,k) -> de k a j
     3059    ! phi, phi2
     3060
     3061    ! initialisations
    30813062    DO j = 1, na
    30823063      DO i = 1, ncum
    3083         epm(i, j, k) = 0.
    3084         epmlmmm(i, j, k) = 0.
    3085         phi(i, j, k) = 0.
    3086         phi2(i, j, k) = 0.
    3087       END DO
    3088     END DO
    3089   END DO
    3090 
    3091   ! fraction deau condensee dans les melanges convertie en precip : epm
    3092   ! et eau condens�e pr�cipit�e dans masse d'air satur� : l_m*dM_m/dzdz.dzdz
    3093   DO j = 1, nam1
    3094     DO k = 1, j - 1
     3064        da(i, j) = 0.
     3065        d1a(i, j) = 0.
     3066        dam(i, j) = 0.
     3067        eplamm(i, j) = 0.
     3068      END DO
     3069    END DO
     3070    DO k = 1, na
     3071      DO j = 1, na
     3072        DO i = 1, ncum
     3073          epm(i, j, k) = 0.
     3074          epmlmmm(i, j, k) = 0.
     3075          phi(i, j, k) = 0.
     3076          phi2(i, j, k) = 0.
     3077        END DO
     3078      END DO
     3079    END DO
     3080
     3081    ! fraction deau condensee dans les melanges convertie en precip : epm
     3082    ! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
     3083    DO j = 1, nam1
     3084      DO k = 1, j - 1
     3085        DO i = 1, ncum
     3086          IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
     3087            !jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
     3088            epm(i, j, k) = 1. - (1. - ep(i, j)) * clw(i, j) / max(elij(i, k, j), 1.E-16)
     3089
     3090            epm(i, j, k) = max(epm(i, j, k), 0.0)
     3091          END IF
     3092        END DO
     3093      END DO
     3094    END DO
     3095
     3096    DO j = 1, nam1
     3097      DO k = 1, nam1
     3098        DO i = 1, ncum
     3099          IF (k>=icb(i) .AND. k<=inb(i)) THEN
     3100            eplamm(i, j) = eplamm(i, j) + ep(i, j) * clw(i, j) * ment(i, j, k) * (1. - &
     3101                    sij(i, j, k))
     3102          END IF
     3103        END DO
     3104      END DO
     3105    END DO
     3106
     3107    DO j = 1, nam1
     3108      DO k = 1, j - 1
     3109        DO i = 1, ncum
     3110          IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
     3111            epmlmmm(i, j, k) = epm(i, j, k) * elij(i, k, j) * ment(i, k, j)
     3112          END IF
     3113        END DO
     3114      END DO
     3115    END DO
     3116
     3117    ! matrices pour calculer la tendance des concentrations dans cvltr.F90
     3118    DO j = 1, nam1
     3119      DO k = 1, nam1
     3120        DO i = 1, ncum
     3121          da(i, j) = da(i, j) + (1. - sij(i, k, j)) * ment(i, k, j)
     3122          phi(i, j, k) = sij(i, k, j) * ment(i, k, j)
     3123          d1a(i, j) = d1a(i, j) + ment(i, k, j) * ep(i, k) * (1. - sij(i, k, j))
     3124        END DO
     3125      END DO
     3126    END DO
     3127
     3128    DO j = 1, nam1
     3129      DO k = 1, j - 1
     3130        DO i = 1, ncum
     3131          dam(i, j) = dam(i, j) + ment(i, k, j) * epm(i, j, k) * (1. - ep(i, k)) * (1. - &
     3132                  sij(i, k, j))
     3133          phi2(i, j, k) = phi(i, j, k) * epm(i, j, k)
     3134        END DO
     3135      END DO
     3136    END DO
     3137
     3138  END SUBROUTINE cv30_tracer
     3139  ! RomP <<<
     3140
     3141  SUBROUTINE cv30_uncompress(nloc, len, ncum, nd, ntra, idcum, iflag, precip, &
     3142          vprecip, evap, ep, sig, w0, ft, fq, fu, fv, ftra, inb, ma, upwd, dnwd, &
     3143          dnwd0, qcondc, wd, cape, da, phi, mp, phi2, d1a, dam, sij, elij, clw, &
     3144          epmlmmm, eplamm, wdtraina, wdtrainm, epmax_diag, iflag1, precip1, vprecip1, evap1, &
     3145          ep1, sig1, w01, ft1, fq1, fu1, fv1, ftra1, inb1, ma1, upwd1, dnwd1, &
     3146          dnwd01, qcondc1, wd1, cape1, da1, phi1, mp1, phi21, d1a1, dam1, sij1, &
     3147          elij1, clw1, epmlmmm1, eplamm1, wdtraina1, wdtrainm1, epmax_diag1) ! epmax_cape
     3148    IMPLICIT NONE
     3149
     3150
     3151
     3152    ! inputs:
     3153    INTEGER len, ncum, nd, ntra, nloc
     3154    INTEGER idcum(nloc)
     3155    INTEGER iflag(nloc)
     3156    INTEGER inb(nloc)
     3157    REAL precip(nloc)
     3158    REAL vprecip(nloc, nd + 1), evap(nloc, nd)
     3159    REAL ep(nloc, nd)
     3160    REAL sig(nloc, nd), w0(nloc, nd)
     3161    REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
     3162    REAL ftra(nloc, nd, ntra)
     3163    REAL ma(nloc, nd)
     3164    REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
     3165    REAL qcondc(nloc, nd)
     3166    REAL wd(nloc), cape(nloc)
     3167    REAL da(nloc, nd), phi(nloc, nd, nd), mp(nloc, nd)
     3168    REAL epmax_diag(nloc) ! epmax_cape
     3169    ! RomP >>>
     3170    REAL phi2(nloc, nd, nd)
     3171    REAL d1a(nloc, nd), dam(nloc, nd)
     3172    REAL wdtraina(nloc, nd), wdtrainm(nloc, nd)
     3173    REAL sij(nloc, nd, nd)
     3174    REAL elij(nloc, nd, nd), clw(nloc, nd)
     3175    REAL epmlmmm(nloc, nd, nd), eplamm(nloc, nd)
     3176    ! RomP <<<
     3177
     3178    ! outputs:
     3179    INTEGER iflag1(len)
     3180    INTEGER inb1(len)
     3181    REAL precip1(len)
     3182    REAL vprecip1(len, nd + 1), evap1(len, nd) !<<< RomP
     3183    REAL ep1(len, nd) !<<< RomP
     3184    REAL sig1(len, nd), w01(len, nd)
     3185    REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
     3186    REAL ftra1(len, nd, ntra)
     3187    REAL ma1(len, nd)
     3188    REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd)
     3189    REAL qcondc1(nloc, nd)
     3190    REAL wd1(nloc), cape1(nloc)
     3191    REAL da1(nloc, nd), phi1(nloc, nd, nd), mp1(nloc, nd)
     3192    REAL epmax_diag1(len) ! epmax_cape
     3193    ! RomP >>>
     3194    REAL phi21(len, nd, nd)
     3195    REAL d1a1(len, nd), dam1(len, nd)
     3196    REAL wdtraina1(len, nd), wdtrainm1(len, nd)
     3197    REAL sij1(len, nd, nd)
     3198    REAL elij1(len, nd, nd), clw1(len, nd)
     3199    REAL epmlmmm1(len, nd, nd), eplamm1(len, nd)
     3200    ! RomP <<<
     3201
     3202    ! local variables:
     3203    INTEGER i, k, j
     3204
     3205    DO i = 1, ncum
     3206      precip1(idcum(i)) = precip(i)
     3207      iflag1(idcum(i)) = iflag(i)
     3208      wd1(idcum(i)) = wd(i)
     3209      inb1(idcum(i)) = inb(i)
     3210      cape1(idcum(i)) = cape(i)
     3211      epmax_diag1(idcum(i)) = epmax_diag(i) ! epmax_cape
     3212    END DO
     3213
     3214    DO k = 1, nl
    30953215      DO i = 1, ncum
    3096         IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
    3097           ! !jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
    3098           epm(i, j, k) = 1. - (1.-ep(i,j))*clw(i, j)/max(elij(i,k,j), 1.E-16)
    3099           ! !
    3100           epm(i, j, k) = max(epm(i,j,k), 0.0)
    3101         END IF
    3102       END DO
    3103     END DO
    3104   END DO
    3105 
    3106   DO j = 1, nam1
    3107     DO k = 1, nam1
     3216        vprecip1(idcum(i), k) = vprecip(i, k)
     3217        evap1(idcum(i), k) = evap(i, k) !<<< RomP
     3218        sig1(idcum(i), k) = sig(i, k)
     3219        w01(idcum(i), k) = w0(i, k)
     3220        ft1(idcum(i), k) = ft(i, k)
     3221        fq1(idcum(i), k) = fq(i, k)
     3222        fu1(idcum(i), k) = fu(i, k)
     3223        fv1(idcum(i), k) = fv(i, k)
     3224        ma1(idcum(i), k) = ma(i, k)
     3225        upwd1(idcum(i), k) = upwd(i, k)
     3226        dnwd1(idcum(i), k) = dnwd(i, k)
     3227        dnwd01(idcum(i), k) = dnwd0(i, k)
     3228        qcondc1(idcum(i), k) = qcondc(i, k)
     3229        da1(idcum(i), k) = da(i, k)
     3230        mp1(idcum(i), k) = mp(i, k)
     3231        ! RomP >>>
     3232        ep1(idcum(i), k) = ep(i, k)
     3233        d1a1(idcum(i), k) = d1a(i, k)
     3234        dam1(idcum(i), k) = dam(i, k)
     3235        clw1(idcum(i), k) = clw(i, k)
     3236        eplamm1(idcum(i), k) = eplamm(i, k)
     3237        wdtraina1(idcum(i), k) = wdtraina(i, k)
     3238        wdtrainm1(idcum(i), k) = wdtrainm(i, k)
     3239        ! RomP <<<
     3240      END DO
     3241    END DO
     3242
     3243    DO i = 1, ncum
     3244      sig1(idcum(i), nd) = sig(i, nd)
     3245    END DO
     3246
     3247
     3248    ! do 2100 j=1,ntra
     3249    ! do 2110 k=1,nd ! oct3
     3250    ! do 2120 i=1,ncum
     3251    ! ftra1(idcum(i),k,j)=ftra(i,k,j)
     3252    ! 2120     continue
     3253    ! 2110    continue
     3254    ! 2100   continue
     3255    DO j = 1, nd
     3256      DO k = 1, nd
     3257        DO i = 1, ncum
     3258          sij1(idcum(i), k, j) = sij(i, k, j)
     3259          phi1(idcum(i), k, j) = phi(i, k, j)
     3260          phi21(idcum(i), k, j) = phi2(i, k, j)
     3261          elij1(idcum(i), k, j) = elij(i, k, j)
     3262          epmlmmm1(idcum(i), k, j) = epmlmmm(i, k, j)
     3263        END DO
     3264      END DO
     3265    END DO
     3266
     3267  END SUBROUTINE cv30_uncompress
     3268
     3269  SUBROUTINE cv30_epmax_fn_cape(nloc, ncum, nd &
     3270          , cape, ep, hp, icb, inb, clw, nk, t, h, lv &
     3271          , epmax_diag)
     3272    USE conema3_mod_h
     3273    USE cvthermo_mod_h
     3274
     3275    IMPLICIT NONE
     3276
     3277    ! On fait varier epmax en fn de la cape
     3278    ! Il faut donc recalculer ep, et hp qui a déjà été calculé et
     3279    ! qui en dépend
     3280    ! Toutes les autres variables fn de ep sont calculées plus bas.
     3281
     3282
     3283
     3284    ! inputs:
     3285    INTEGER ncum, nd, nloc
     3286    INTEGER icb(nloc), inb(nloc)
     3287    REAL cape(nloc)
     3288    REAL clw(nloc, nd), lv(nloc, nd), t(nloc, nd), h(nloc, nd)
     3289    INTEGER nk(nloc)
     3290    ! inouts:
     3291    REAL ep(nloc, nd)
     3292    REAL hp(nloc, nd)
     3293    ! outputs ou local
     3294    REAL epmax_diag(nloc)
     3295    ! locals
     3296    INTEGER i, k
     3297    REAL hp_bak(nloc, nd)
     3298    CHARACTER (LEN = 20) :: modname = 'cv30_epmax_fn_cape'
     3299    CHARACTER (LEN = 80) :: abort_message
     3300
     3301    ! on recalcule ep et hp
     3302
     3303    IF (coef_epmax_cape>1e-12) THEN
    31083304      DO i = 1, ncum
    3109         IF (k>=icb(i) .AND. k<=inb(i)) THEN
    3110           eplamm(i, j) = eplamm(i, j) + ep(i, j)*clw(i, j)*ment(i, j, k)*(1.- &
    3111             sij(i,j,k))
    3112         END IF
    3113       END DO
    3114     END DO
    3115   END DO
    3116 
    3117   DO j = 1, nam1
    3118     DO k = 1, j - 1
     3305        epmax_diag(i) = epmax - coef_epmax_cape * sqrt(cape(i))
     3306        DO k = 1, nl
     3307          ep(i, k) = ep(i, k) / epmax * epmax_diag(i)
     3308          ep(i, k) = amax1(ep(i, k), 0.0)
     3309          ep(i, k) = amin1(ep(i, k), epmax_diag(i))
     3310        enddo
     3311      enddo
     3312
     3313      ! On recalcule hp:
     3314      DO k = 1, nl
     3315        DO i = 1, ncum
     3316          hp_bak(i, k) = hp(i, k)
     3317        enddo
     3318      enddo
     3319      DO k = 1, nlp
     3320        DO i = 1, ncum
     3321          hp(i, k) = h(i, k)
     3322        enddo
     3323      enddo
     3324      DO k = minorig + 1, nl
     3325        DO i = 1, ncum
     3326          IF((k>=icb(i)).AND.(k<=inb(i)))THEN
     3327            hp(i, k) = h(i, nk(i)) + (lv(i, k) + (cpd - cpv) * t(i, k)) * ep(i, k) * clw(i, k)
     3328          endif
     3329        enddo
     3330      enddo !do k=minorig+1,n
     3331      !     WRITE(*,*) 'cv30_routines 6218: hp(1,20)=',hp(1,20)
    31193332      DO i = 1, ncum
    3120         IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
    3121           epmlmmm(i, j, k) = epm(i, j, k)*elij(i, k, j)*ment(i, k, j)
    3122         END IF
    3123       END DO
    3124     END DO
    3125   END DO
    3126 
    3127   ! matrices pour calculer la tendance des concentrations dans cvltr.F90
    3128   DO j = 1, nam1
    3129     DO k = 1, nam1
    3130       DO i = 1, ncum
    3131         da(i, j) = da(i, j) + (1.-sij(i,k,j))*ment(i, k, j)
    3132         phi(i, j, k) = sij(i, k, j)*ment(i, k, j)
    3133         d1a(i, j) = d1a(i, j) + ment(i, k, j)*ep(i, k)*(1.-sij(i,k,j))
    3134       END DO
    3135     END DO
    3136   END DO
    3137 
    3138   DO j = 1, nam1
    3139     DO k = 1, j - 1
    3140       DO i = 1, ncum
    3141         dam(i, j) = dam(i, j) + ment(i, k, j)*epm(i, j, k)*(1.-ep(i,k))*(1.- &
    3142           sij(i,k,j))
    3143         phi2(i, j, k) = phi(i, j, k)*epm(i, j, k)
    3144       END DO
    3145     END DO
    3146   END DO
    3147 
    3148   RETURN
    3149 END SUBROUTINE cv30_tracer
    3150 ! RomP <<<
    3151 
    3152 SUBROUTINE cv30_uncompress(nloc, len, ncum, nd, ntra, idcum, iflag, precip, &
    3153     vprecip, evap, ep, sig, w0, ft, fq, fu, fv, ftra, inb, ma, upwd, dnwd, &
    3154     dnwd0, qcondc, wd, cape, da, phi, mp, phi2, d1a, dam, sij, elij, clw, &
    3155     epmlmmm, eplamm, wdtraina, wdtrainm,epmax_diag, iflag1, precip1, vprecip1, evap1, &
    3156     ep1, sig1, w01, ft1, fq1, fu1, fv1, ftra1, inb1, ma1, upwd1, dnwd1, &
    3157     dnwd01, qcondc1, wd1, cape1, da1, phi1, mp1, phi21, d1a1, dam1, sij1, &
    3158     elij1, clw1, epmlmmm1, eplamm1, wdtraina1, wdtrainm1,epmax_diag1) ! epmax_cape
    3159   IMPLICIT NONE
    3160 
    3161   include "cv30param.h"
    3162 
    3163   ! inputs:
    3164   INTEGER len, ncum, nd, ntra, nloc
    3165   INTEGER idcum(nloc)
    3166   INTEGER iflag(nloc)
    3167   INTEGER inb(nloc)
    3168   REAL precip(nloc)
    3169   REAL vprecip(nloc, nd+1), evap(nloc, nd)
    3170   REAL ep(nloc, nd)
    3171   REAL sig(nloc, nd), w0(nloc, nd)
    3172   REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
    3173   REAL ftra(nloc, nd, ntra)
    3174   REAL ma(nloc, nd)
    3175   REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
    3176   REAL qcondc(nloc, nd)
    3177   REAL wd(nloc), cape(nloc)
    3178   REAL da(nloc, nd), phi(nloc, nd, nd), mp(nloc, nd)
    3179   REAL epmax_diag(nloc) ! epmax_cape
    3180   ! RomP >>>
    3181   REAL phi2(nloc, nd, nd)
    3182   REAL d1a(nloc, nd), dam(nloc, nd)
    3183   REAL wdtraina(nloc, nd), wdtrainm(nloc, nd)
    3184   REAL sij(nloc, nd, nd)
    3185   REAL elij(nloc, nd, nd), clw(nloc, nd)
    3186   REAL epmlmmm(nloc, nd, nd), eplamm(nloc, nd)
    3187   ! RomP <<<
    3188 
    3189   ! outputs:
    3190   INTEGER iflag1(len)
    3191   INTEGER inb1(len)
    3192   REAL precip1(len)
    3193   REAL vprecip1(len, nd+1), evap1(len, nd) !<<< RomP
    3194   REAL ep1(len, nd) !<<< RomP
    3195   REAL sig1(len, nd), w01(len, nd)
    3196   REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
    3197   REAL ftra1(len, nd, ntra)
    3198   REAL ma1(len, nd)
    3199   REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd)
    3200   REAL qcondc1(nloc, nd)
    3201   REAL wd1(nloc), cape1(nloc)
    3202   REAL da1(nloc, nd), phi1(nloc, nd, nd), mp1(nloc, nd)
    3203   REAL epmax_diag1(len) ! epmax_cape
    3204   ! RomP >>>
    3205   REAL phi21(len, nd, nd)
    3206   REAL d1a1(len, nd), dam1(len, nd)
    3207   REAL wdtraina1(len, nd), wdtrainm1(len, nd)
    3208   REAL sij1(len, nd, nd)
    3209   REAL elij1(len, nd, nd), clw1(len, nd)
    3210   REAL epmlmmm1(len, nd, nd), eplamm1(len, nd)
    3211   ! RomP <<<
    3212 
    3213   ! local variables:
    3214   INTEGER i, k, j
    3215 
    3216   DO i = 1, ncum
    3217     precip1(idcum(i)) = precip(i)
    3218     iflag1(idcum(i)) = iflag(i)
    3219     wd1(idcum(i)) = wd(i)
    3220     inb1(idcum(i)) = inb(i)
    3221     cape1(idcum(i)) = cape(i)
    3222     epmax_diag1(idcum(i))=epmax_diag(i) ! epmax_cape
    3223   END DO
    3224 
    3225   DO k = 1, nl
    3226     DO i = 1, ncum
    3227       vprecip1(idcum(i), k) = vprecip(i, k)
    3228       evap1(idcum(i), k) = evap(i, k) !<<< RomP
    3229       sig1(idcum(i), k) = sig(i, k)
    3230       w01(idcum(i), k) = w0(i, k)
    3231       ft1(idcum(i), k) = ft(i, k)
    3232       fq1(idcum(i), k) = fq(i, k)
    3233       fu1(idcum(i), k) = fu(i, k)
    3234       fv1(idcum(i), k) = fv(i, k)
    3235       ma1(idcum(i), k) = ma(i, k)
    3236       upwd1(idcum(i), k) = upwd(i, k)
    3237       dnwd1(idcum(i), k) = dnwd(i, k)
    3238       dnwd01(idcum(i), k) = dnwd0(i, k)
    3239       qcondc1(idcum(i), k) = qcondc(i, k)
    3240       da1(idcum(i), k) = da(i, k)
    3241       mp1(idcum(i), k) = mp(i, k)
    3242       ! RomP >>>
    3243       ep1(idcum(i), k) = ep(i, k)
    3244       d1a1(idcum(i), k) = d1a(i, k)
    3245       dam1(idcum(i), k) = dam(i, k)
    3246       clw1(idcum(i), k) = clw(i, k)
    3247       eplamm1(idcum(i), k) = eplamm(i, k)
    3248       wdtraina1(idcum(i), k) = wdtraina(i, k)
    3249       wdtrainm1(idcum(i), k) = wdtrainm(i, k)
    3250       ! RomP <<<
    3251     END DO
    3252   END DO
    3253 
    3254   DO i = 1, ncum
    3255     sig1(idcum(i), nd) = sig(i, nd)
    3256   END DO
    3257 
    3258 
    3259   ! do 2100 j=1,ntra
    3260   ! do 2110 k=1,nd ! oct3
    3261   ! do 2120 i=1,ncum
    3262   ! ftra1(idcum(i),k,j)=ftra(i,k,j)
    3263   ! 2120     continue
    3264   ! 2110    continue
    3265   ! 2100   continue
    3266   DO j = 1, nd
    3267     DO k = 1, nd
    3268       DO i = 1, ncum
    3269         sij1(idcum(i), k, j) = sij(i, k, j)
    3270         phi1(idcum(i), k, j) = phi(i, k, j)
    3271         phi21(idcum(i), k, j) = phi2(i, k, j)
    3272         elij1(idcum(i), k, j) = elij(i, k, j)
    3273         epmlmmm1(idcum(i), k, j) = epmlmmm(i, k, j)
    3274       END DO
    3275     END DO
    3276   END DO
    3277 
    3278   RETURN
    3279 END SUBROUTINE cv30_uncompress
    3280 
    3281         subroutine cv30_epmax_fn_cape(nloc,ncum,nd &
    3282                 ,cape,ep,hp,icb,inb,clw,nk,t,h,lv &
    3283                 ,epmax_diag)
    3284         USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    3285           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    3286         implicit none
    3287 
    3288         ! On fait varier epmax en fn de la cape
    3289         ! Il faut donc recalculer ep, et hp qui a d�j� �t� calcul� et
    3290         ! qui en d�pend
    3291         ! Toutes les autres variables fn de ep sont calcul�es plus bas.
    3292 
    3293         INCLUDE "cv30param.h"
    3294         INCLUDE "conema3.h"
    3295 
    3296 ! inputs:
    3297       integer ncum, nd, nloc
    3298       integer icb(nloc), inb(nloc)
    3299       real cape(nloc)
    3300       real clw(nloc,nd),lv(nloc,nd),t(nloc,nd),h(nloc,nd)
    3301       integer nk(nloc)
    3302 ! inouts:
    3303       real ep(nloc,nd)
    3304       real hp(nloc,nd)
    3305 ! outputs ou local
    3306       real epmax_diag(nloc)
    3307 ! locals
    3308       integer i,k   
    3309       real hp_bak(nloc,nd)
    3310       CHARACTER (LEN=20) :: modname='cv30_epmax_fn_cape'
    3311       CHARACTER (LEN=80) :: abort_message
    3312 
    3313         ! on recalcule ep et hp
    3314        
    3315         if (coef_epmax_cape.gt.1e-12) then
    3316         do i=1,ncum
    3317            epmax_diag(i)=epmax-coef_epmax_cape*sqrt(cape(i))
    3318            do k=1,nl
    3319                 ep(i,k)=ep(i,k)/epmax*epmax_diag(i)
    3320                 ep(i,k)=amax1(ep(i,k),0.0)
    3321                 ep(i,k)=amin1(ep(i,k),epmax_diag(i))
    3322            enddo
    3323         enddo
    3324 
    3325 ! On recalcule hp:
    3326       do k=1,nl
    3327         do i=1,ncum
    3328           hp_bak(i,k)=hp(i,k)
    3329         enddo
    3330       enddo
    3331       do k=1,nlp
    3332         do i=1,ncum
    3333           hp(i,k)=h(i,k)
    3334         enddo
    3335       enddo
    3336       do k=minorig+1,nl
    3337        do i=1,ncum
    3338         if((k.ge.icb(i)).and.(k.le.inb(i)))then
    3339           hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
    3340         endif
    3341        enddo
    3342       enddo !do k=minorig+1,n
    3343 !     write(*,*) 'cv30_routines 6218: hp(1,20)=',hp(1,20)
    3344       do i=1,ncum 
    3345        do k=1,nl
    3346         if (abs(hp_bak(i,k)-hp(i,k)).gt.0.01) then
    3347            write(*,*) 'i,k=',i,k
    3348            write(*,*) 'coef_epmax_cape=',coef_epmax_cape
    3349            write(*,*) 'epmax_diag(i)=',epmax_diag(i)
    3350            write(*,*) 'ep(i,k)=',ep(i,k)
    3351            write(*,*) 'hp(i,k)=',hp(i,k)
    3352            write(*,*) 'hp_bak(i,k)=',hp_bak(i,k)
    3353            write(*,*) 'h(i,k)=',h(i,k)
    3354            write(*,*) 'nk(i)=',nk(i)
    3355            write(*,*) 'h(i,nk(i))=',h(i,nk(i))
    3356            write(*,*) 'lv(i,k)=',lv(i,k)
    3357            write(*,*) 't(i,k)=',t(i,k)
    3358            write(*,*) 'clw(i,k)=',clw(i,k)
    3359            write(*,*) 'cpd,cpv=',cpd,cpv
    3360            CALL abort_physic(modname,abort_message,1)
    3361         endif
    3362        enddo !do k=1,nl
    3363       enddo !do i=1,ncum 
    3364       endif !if (coef_epmax_cape.gt.1e-12) then
    3365 
    3366       return
    3367       end subroutine cv30_epmax_fn_cape
    3368 
    3369 
     3333        DO k = 1, nl
     3334          IF (abs(hp_bak(i, k) - hp(i, k))>0.01) THEN
     3335            WRITE(*, *) 'i,k=', i, k
     3336            WRITE(*, *) 'coef_epmax_cape=', coef_epmax_cape
     3337            WRITE(*, *) 'epmax_diag(i)=', epmax_diag(i)
     3338            WRITE(*, *) 'ep(i,k)=', ep(i, k)
     3339            WRITE(*, *) 'hp(i,k)=', hp(i, k)
     3340            WRITE(*, *) 'hp_bak(i,k)=', hp_bak(i, k)
     3341            WRITE(*, *) 'h(i,k)=', h(i, k)
     3342            WRITE(*, *) 'nk(i)=', nk(i)
     3343            WRITE(*, *) 'h(i,nk(i))=', h(i, nk(i))
     3344            WRITE(*, *) 'lv(i,k)=', lv(i, k)
     3345            WRITE(*, *) 't(i,k)=', t(i, k)
     3346            WRITE(*, *) 'clw(i,k)=', clw(i, k)
     3347            WRITE(*, *) 'cpd,cpv=', cpd, cpv
     3348            CALL abort_physic(modname, abort_message, 1)
     3349          endif
     3350        enddo !do k=1,nl
     3351      enddo !do i=1,ncum
     3352    ENDIF !if (coef_epmax_cape.gt.1e-12) THEN
     3353  END SUBROUTINE  cv30_epmax_fn_cape
     3354
     3355
     3356END MODULE cv30_routines_mod
     3357
     3358

  • LMDZ6/trunk/libf/phylmd/cv3_routines.f90

    r5276 r5283  
    1111  USE ioipsl_getin_p_mod, ONLY : getin_p
    1212  use mod_phys_lmdz_para
     13  USE conema3_mod_h
    1314  IMPLICIT NONE
    1415
    … …  
    3738
    3839  include "cv3param.h"
    39   include "conema3.h"
    4040
    4141  INTEGER, INTENT(IN)              :: nd
    … …  
    11481148  USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    11491149          , clmci, eps, epsi, epsim1, ginv, hrd, grav
     1150  USE conema3_mod_h
    11501151  IMPLICIT NONE
    11511152
    … …  
    11691170
    11701171  include "cv3param.h"
    1171   include "conema3.h"
    11721172  include "YOMCST2.h"
    11731173
    … …  
    34713471                     ftd, fqd, qta, qtc, sigt, detrain, tau_cld_cv, coefw_cld_cv)
    34723472
    3473     USE print_control_mod, ONLY: lunout, prt_level
     3473USE conema3_mod_h
     3474      USE print_control_mod, ONLY: lunout, prt_level
    34743475    USE add_phys_tend_mod, only : fl_cor_ebil
    34753476    USE cvflag_mod_h, ONLY: icvflag_Tpa, cvflag_grav, cvflag_ice, ok_optim_yield, ok_entrain, ok_homo_tend, &
    … …  
    34803481
    34813482  include "cv3param.h"
    3482   include "conema3.h"
    34833483
    34843484!inputs:
    … …  
    51605160                 , pbase, p, ph, tv, buoy, sig, w0,iflag &
    51615161                 , epmax_diag)
    5162           USE cvflag_mod_h, ONLY: icvflag_Tpa, cvflag_grav, cvflag_ice, ok_optim_yield, ok_entrain, ok_homo_tend, &
     5162USE conema3_mod_h
     5163            USE cvflag_mod_h, ONLY: icvflag_Tpa, cvflag_grav, cvflag_ice, ok_optim_yield, ok_entrain, ok_homo_tend, &
    51635164          ok_convstop, ok_intermittent, cvflag_prec_eject, qsat_depends_on_qt, adiab_ascent_mass_flux_depends_on_ejectliq, keepbug_ice_frac
    51645165          USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    … …  
    51725173
    51735174  include "cv3param.h"
    5174   include "conema3.h"
    51755175
    51765176! inputs:

  • LMDZ6/trunk/libf/phylmd/cv3p1_closure.f90

    r5276 r5283  
    1919  ! **************************************************************
    2020
    21   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
     21USE conema3_mod_h
     22    USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    2223          , clmci, eps, epsi, epsim1, ginv, hrd, grav
    2324  USE print_control_mod, ONLY: prt_level, lunout
    … …  
    3940  include "YOMCST2.h"
    4041
    41   include "conema3.h"
    4242
    4343  ! input:

  • LMDZ6/trunk/libf/phylmd/cv3p2_closure.f90

    r5276 r5283  
    1818  ! **************************************************************
    1919
    20   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
     20USE conema3_mod_h
     21    USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    2122          , clmci, eps, epsi, epsim1, ginv, hrd, grav
    2223  USE cvflag_mod_h, ONLY: icvflag_Tpa, cvflag_grav, cvflag_ice, ok_optim_yield, ok_entrain, ok_homo_tend, &
    … …  
    4041  include "YOMCST2.h"
    4142
    42   include "conema3.h"
    4343
    4444  ! input:

  • LMDZ6/trunk/libf/phylmd/cv_driver.F90

    r5276 r5283  
    1212
    1313  USE dimphy
     14  USE cv30_routines_mod, ONLY: cv30_param, cv30_prelim, cv30_feed, cv30_undilute1, cv30_trigger, cv30_compress, cv30_undilute2, &
     15          cv30_closure, cv30_epmax_fn_cape, cv30_mixing, cv30_unsat, cv30_yield, cv30_tracer, cv30_uncompress
    1416  IMPLICIT NONE
    1517

  • LMDZ6/trunk/libf/phylmd/cvltr.f90

    r5274 r5283  
    1010           qPa,qMel,qTrdi,dtrcvMA,Mint,                   &
    1111           zmfd1a,zmfphi2,zmfdam)
    12   USE IOIPSL
     12USE conema3_mod_h
     13    USE IOIPSL
    1314  USE dimphy
    1415  USE infotrac_phy, ONLY : nbtr
    … …  
    3435
    3536  include "YOECUMF.h"
    36   include "conema3.h"
    3737
    3838! Entree

  • LMDZ6/trunk/libf/phylmd/cvltr_scav.f90

    r5274 r5283  
    1111     zmfd1a,zmfphi2,zmfdam)
    1212  !
    13   USE IOIPSL
     13USE conema3_mod_h
     14    USE IOIPSL
    1415  USE dimphy
    1516  USE infotrac_phy, ONLY : nbtr
    … …  
    3536
    3637  include "YOECUMF.h"
    37   include "conema3.h"
    3838  include "chem.h"
    3939

  • LMDZ6/trunk/libf/phylmd/cvltr_spl.f90

    r5274 r5283  
    1111           qPa,qMel,qTrdi,dtrcvMA,Mint,                   &
    1212           zmfd1a,zmfphi2,zmfdam)
    13   USE IOIPSL
     13USE conema3_mod_h
     14    USE IOIPSL
    1415  USE dimphy
    1516  USE infotrac_phy, ONLY : nbtr
    … …  
    3536
    3637  include "YOECUMF.h"
    37   include "conema3.h"
    3838  include "chem.h"
    3939

  • LMDZ6/trunk/libf/phylmd/dyn1d/tracstoke_mod_h.f90

    r5282 r5283  
    1 link ../../dyn3d_common/tracstoke.h
     1link ../../dyn3d_common/tracstoke_mod_h.f90

  • LMDZ6/trunk/libf/phylmd/physiq_mod.F90

    r5282 r5283  
    371371          , RALPD, RBETD, RGAMD
    372372       USE clesphys_mod_h
     373       USE conema3_mod_h
    373374
    374375    IMPLICIT NONE
    … …  
    11841185    include "YOETHF.h"
    11851186    include "FCTTRE.h"
    1186     !IM 100106 BEG : pouvoir sortir les ctes de la physique
    1187     include "conema3.h"
    11881187    include "nuage.h"
    11891188    include "compbl.h"

  • LMDZ6/trunk/libf/phylmdiso/concvl.F90

    r5282 r5283  
    7676          , RESTT, RALPW, RBETW, RGAMW, RALPS, RBETS, RGAMS            &
    7777          , RALPD, RBETD, RGAMD
     78  USE conema3_mod_h
    7879  IMPLICIT NONE
    7980! ======================================================================
    … …  
    310311  include "YOETHF.h"
    311312  include "FCTTRE.h"
    312 !jyg<
    313   include "conema3.h"
    314 !>jyg
    315313
    316314  IF (first) THEN

  • LMDZ6/trunk/libf/phylmdiso/conema3_mod_h.f90

    r5282 r5283  
    1 link ../phylmd/conema3.h
     1link ../phylmd/conema3_mod_h.f90

  • LMDZ6/trunk/libf/phylmdiso/cv30_routines_mod.F90

    r5282 r5283  
    1 
    2 ! $Id$
    3 
     1MODULE cv30_routines_mod
     2  !------------------------------------------------------------
     3  ! Parameters for convectL, iflag_con=30:
     4  ! (includes - microphysical parameters,
     5  !            - parameters that control the rate of approach
     6  !               to quasi-equilibrium)
     7  !            - noff & minorig (previously in input of convect1)
     8  !------------------------------------------------------------
     9
     10  IMPLICIT NONE; PRIVATE
     11  PUBLIC sigd, spfac, pbcrit, ptcrit, omtrain, dtovsh, dpbase, dttrig, dtcrit, &
     12          tau, beta, alpha, delta, betad, noff, minorig, nl, nlp, nlm, &
     13          cv30_param, cv30_prelim, cv30_feed, cv30_undilute1, cv30_trigger, &
     14          cv30_compress, cv30_undilute2, cv30_closure, cv30_mixing, cv30_unsat, &
     15          cv30_yield, cv30_tracer, cv30_uncompress, cv30_epmax_fn_cape
     16
     17  INTEGER noff, minorig, nl, nlp, nlm
     18  REAL sigd, spfac
     19  REAL pbcrit, ptcrit
     20  REAL omtrain
     21  REAL dtovsh, dpbase, dttrig
     22  REAL dtcrit, tau, beta, alpha
     23  REAL delta
     24  REAL betad
     25
     26  !$OMP THREADPRIVATE(sigd, spfac, pbcrit, ptcrit, omtrain, dtovsh, dpbase, dttrig, dtcrit, &
     27  !$OMP      tau, beta, alpha, delta, betad, noff, minorig, nl, nlp, nlm)
     28CONTAINS
    429
    530
    631SUBROUTINE cv30_param(nd, delt)
    7   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    8           , clmci, eps, epsi, epsim1, ginv, hrd, grav
     32  USE conema3_mod_h
     33
    934  IMPLICIT NONE
    1035
    … …  
    3257  ! ***                     IT MUST BE LESS THAN 0              ***
    3358
    34   include "cv30param.h"
    35   include "conema3.h"
    36 
    3759  INTEGER nd
    3860  REAL delt ! timestep (seconds)
    … …  
    82104  betad = 10.0 ! original value (from convect 4.3)
    83105
    84   RETURN
     106
    85107END SUBROUTINE cv30_param
    86108
    87109SUBROUTINE cv30_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm, &
    88110    th)
    89   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    90           , clmci, eps, epsi, epsim1, ginv, hrd, grav
     111
     112  USE cvthermo_mod_h
    91113  IMPLICIT NONE
    92114
    … …  
    111133  REAL tvx, tvy ! convect3
    112134  REAL cpx(len, nd)
    113 
    114   include "cv30param.h"
    115135
    116136
    … …  
    158178  END DO
    159179
    160   RETURN
     180
    161181END SUBROUTINE cv30_prelim
    162182
    … …  
    164184    iflag, tnk, qnk, gznk, plcl &
    165185#ifdef ISO
    166     ,xt,xtnk  & 
     186    ,xt,xtnk  &
    167187#endif
    168188    )
    … …  
    186206  ! ================================================================
    187207
    188   include "cv30param.h"
     208
    189209
    190210  ! inputs:
    … …  
    194214  REAL ph(len, nd+1)
    195215#ifdef ISO
    196   real xt(ntraciso,len,nd)     
     216  REAL xt(ntraciso,len,nd)
    197217#endif
    198218
    … …  
    201221  REAL tnk(len), qnk(len), gznk(len), plcl(len)
    202222#ifdef ISO
    203   real xtnk(ntraciso,len)     
     223  REAL xtnk(ntraciso,len)
    204224#endif
    205225
    … …  
    207227  INTEGER i, k
    208228#ifdef ISO
    209         integer ixt
     229        INTEGER ixt
    210230#endif
    211231  INTEGER ihmin(len)
    … …  
    228248  ! @       do 200 k=2,nlp
    229249  ! @         do 190 i=1,len
    230   ! @          if((hm(i,k).lt.work(i)).and.
    231   ! @      &      (hm(i,k).lt.hm(i,k-1)))then
     250  ! @          if((hm(i,k).lt.work(i)).AND.
     251  ! @      &      (hm(i,k).lt.hm(i,k-1)))THEN
    232252  ! @            work(i)=hm(i,k)
    233253  ! @            ihmin(i)=k
    … …  
    237257  ! @       do 210 i=1,len
    238258  ! @         ihmin(i)=min(ihmin(i),nlm)
    239   ! @         if(ihmin(i).le.minorig)then
     259  ! @         IF(ihmin(i).le.minorig)THEN
    240260  ! @           iflag(i)=6
    241261  ! @         endif
    … …  
    253273  ! @       do 240 k=minorig+1,nl
    254274  ! @         do 230 i=1,len
    255   ! @          if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
     275  ! @          if((hm(i,k).gt.work(i)).AND.(k.le.ihmin(i)))THEN
    256276  ! @            work(i)=hm(i,k)
    257277  ! @            nk(i)=k
    … …  
    273293  ! -------------------------------------------------------------------
    274294  DO i = 1, len
    275     IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0)) & ! @      &       .or.(
     295    IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0)) & ! @      &       .OR.(
    276296                                                      ! p(i,ihmin(i)).lt.400.0
    277297                                                      ! )  )
    … …  
    296316      qsnk(i) = qs(i, nk(i))
    297317#ifdef ISO
    298       do ixt=1,ntraciso
     318      DO ixt=1,ntraciso
    299319        xtnk(ixt,i) = xt(ixt,i, nk(i))
    300320      enddo
    … …  
    323343  ! @      do 290 k=minorig,nl
    324344  ! @        do 280 i=1,len
    325   ! @          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
     345  ! @          if((k.ge.(nk(i)+1)).AND.(p(i,k).lt.plcl(i)))
    326346  ! @     &    icb(i)=min(icb(i),k)
    327347  ! @ 280    continue
    … …  
    329349  ! @c
    330350  ! @      do 300 i=1,len
    331   ! @        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
     351  ! @        if((icb(i).ge.nlm).AND.(iflag(i).EQ.0))iflag(i)=9
    332352  ! @ 300  continue
    333353
    … …  
    346366
    347367  DO i = 1, len
    348     ! @        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
     368    ! @        if((icb(i).ge.nlm).AND.(iflag(i).EQ.0))iflag(i)=9
    349369    IF ((icb(i)==nlm) .AND. (iflag(i)==0)) iflag(i) = 9
    350370  END DO
    … …  
    358378  icbmax = 2
    359379  DO i = 1, len
    360     ! !        icbmax=max(icbmax,icb(i))
     380    !        icbmax=max(icbmax,icb(i))
    361381    IF (iflag(i)<7) icbmax = max(icbmax, icb(i)) ! sb Jun7th02
    362382  END DO
    363383
    364   RETURN
     384
    365385END SUBROUTINE cv30_feed
    366386
    … …  
    368388    clw, icbs &
    369389#ifdef ISO
    370      &                       ,xt,xtclw &
    371 #endif
    372      &                       )
     390                             ,xt,xtclw &
     391#endif
     392                             )
    373393
    374394#ifdef ISO
    … …  
    380400USE isotopes_routines_mod, ONLY: condiso_liq_ice_vectall_trac
    381401#ifdef ISOVERIF
    382     use isotopes_verif_mod, ONLY: iso_verif_traceur
    383 #endif
    384 #endif
    385 #ifdef ISOVERIF
    386     use isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif, &
     402    USE isotopes_verif_mod, ONLY: iso_verif_traceur
     403#endif
     404#endif
     405#ifdef ISOVERIF
     406    USE isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif, &
    387407        iso_verif_egalite_choix, iso_verif_noNaN,iso_verif_aberrant, &
    388408        iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
    … …  
    391411#endif
    392412#endif
    393 
    394   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    395           , clmci, eps, epsi, epsim1, ginv, hrd, grav
     413USE cvthermo_mod_h
     414
    396415  IMPLICIT NONE
    397416
    … …  
    409428  ! ----------------------------------------------------------------
    410429
    411   include "cv30param.h"
    412430
    413431  ! inputs:
    … …  
    418436  REAL plcl(len) ! convect3
    419437#ifdef ISO
    420       real xt(ntraciso,len,nd)
     438      REAL xt(ntraciso,len,nd)
    421439#endif
    422440
    … …  
    424442  REAL tp(len, nd), tvp(len, nd), clw(len, nd)
    425443#ifdef ISO
    426       real xtclw(ntraciso,len,nd)
    427       real tg_save(len,nd)
     444      REAL xtclw(ntraciso,len,nd)
     445      REAL tg_save(len,nd)
    428446#endif
    429447
    … …  
    437455  REAL cpinv(len) ! convect3
    438456#ifdef ISO
    439       integer ixt
    440       real zfice(len),zxtliq(ntraciso,len),zxtice(ntraciso,len)
    441       real q_k(len),clw_k(len),tg_k(len),xt_k(ntraciso,len)
    442 !#ifdef ISOVERIF     
     457      INTEGER ixt
     458      REAL zfice(len),zxtliq(ntraciso,len),zxtice(ntraciso,len)
     459      REAL q_k(len),clw_k(len),tg_k(len),xt_k(ntraciso,len)
     460!#ifdef ISOVERIF
    443461!      integer iso_verif_positif_nostop
    444462!#endif
    … …  
    453471
    454472#ifdef ISOVERIF
    455         write(*,*) 'cv30_routine undilute 1 413: entree'
     473        WRITE(*,*) 'cv30_routine undilute 1 413: entree'
    456474#endif
    457475
    … …  
    493511
    494512  ! Re-compute icbsmax (icbsmax2):        !convect3
    495   ! !convect3
     513  !convect3
    496514  icbsmax2 = 2 !convect3
    497515  DO i = 1, len !convect3
    … …  
    507525      clw(i, k) = 0.0 ! convect3
    508526#ifdef ISO
    509         do ixt=1,ntraciso
     527        DO ixt=1,ntraciso
    510528         xtclw(ixt,i,k) = 0.0
    511529        enddo
    512        
     530
    513531#endif
    514532    END DO ! convect3
    … …  
    548566    denom = 243.5 + tc
    549567    denom = max(denom, 1.0) ! convect3
    550     ! ori          if(tc.ge.0.0)then
     568    ! ori          IF(tc.ge.0.0)THEN
    551569    es = 6.112*exp(17.67*tc/denom)
    552570    ! ori          else
    … …  
    570588    denom = 243.5 + tc
    571589    denom = max(denom, 1.0) ! convect3
    572     ! ori          if(tc.ge.0.0)then
     590    ! ori          IF(tc.ge.0.0)THEN
    573591    es = 6.112*exp(17.67*tc/denom)
    574592    ! ori          else
    … …  
    602620#ifdef ISO
    603621       ! calcul de zfice
    604        do i=1,len
     622       DO i=1,len
    605623          zfice(i) = 1.0-(t(i,icbs(i))-pxtice)/(pxtmelt-pxtice)
    606           zfice(i) = MIN(MAX(zfice(i),0.0),1.0)         
     624          zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
    607625       enddo
    608626       ! calcul de la composition du condensat glace et liquide
    609627
    610        do i=1,len
     628       DO i=1,len
    611629         clw_k(i)=clw(i,icbs(i))
    612          tg_k(i)=t(i,icbs(i)) 
    613          do ixt=1,ntraciso
    614             xt_k(ixt,i)=xt(ixt,i,nk(i)) 
    615           enddo         
     630         tg_k(i)=t(i,icbs(i))
     631         DO ixt=1,ntraciso
     632            xt_k(ixt,i)=xt(ixt,i,nk(i))
     633          enddo
    616634       enddo
    617635#ifdef ISOVERIF
    618         write(*,*) 'cv30_routine undilute1 573: avant condiso'
    619         write(*,*) 't(1,1)=',t(1,1)                 
    620         do i=1,len
    621            call iso_verif_positif(t(i,icbs(i))-Tmin_verif, &
    622      &        'cv30_routines 654')
     636        WRITE(*,*) 'cv30_routine undilute1 573: avant condiso'
     637        WRITE(*,*) 't(1,1)=',t(1,1)
     638        DO i=1,len
     639           CALL iso_verif_positif(t(i,icbs(i))-Tmin_verif, &
     640              'cv30_routines 654')
    623641        enddo
    624         if (iso_HDO.gt.0) then           
    625          do i=1,len
    626           if (qnk(i).gt.ridicule) then
    627            call iso_verif_aberrant(xt_k(iso_hdo,i)/qnk(i), &
    628      &            'cv30_routines 576')
    629            endif  !if (qnk(i).gt.ridicule) then
    630          enddo       
    631         endif !if (iso_HDO.gt.0) then
    632 !        write(*,*) 'i=1, clw_k,qnk=',clw_k(1),qnk(1)
    633 #endif
    634        call condiso_liq_ice_vectall(xt_k(1,1),qnk(1), &
    635      &        clw_k(1),tg_k(1), &
    636      &        zfice(1),zxtice(1,1),zxtliq(1,1),len)
     642        IF (iso_HDO.gt.0) THEN
     643         DO i=1,len
     644          IF (qnk(i).gt.ridicule) THEN
     645           CALL iso_verif_aberrant(xt_k(iso_hdo,i)/qnk(i), &
     646                  'cv30_routines 576')
     647           endif  !if (qnk(i).gt.ridicule) THEN
     648         enddo
     649        endif !if (iso_HDO.gt.0) THEN
     650!        WRITE(*,*) 'i=1, clw_k,qnk=',clw_k(1),qnk(1)
     651#endif
     652       CALL condiso_liq_ice_vectall(xt_k(1,1),qnk(1), &
     653              clw_k(1),tg_k(1), &
     654              zfice(1),zxtice(1,1),zxtliq(1,1),len)
    637655#ifdef ISOTRAC
    638656#ifdef ISOVERIF
    639         write(*,*) 'cv30_routines 658: call condiso_liq_ice_vectall_trac'
    640 #endif
    641         call condiso_liq_ice_vectall_trac(xt_k(1,1),qnk(1), &
    642      &        clw_k(1),tg_k(1), &
    643      &        zfice(1),zxtice(1,1),zxtliq(1,1),len)
    644 #endif
    645        do i=1,len
    646          do ixt = 1, ntraciso   
    647            xtclw(ixt,i,icbs(i))=  zxtice(ixt,i)+zxtliq(ixt,i)   
     657        WRITE(*,*) 'cv30_routines 658: CALL condiso_liq_ice_vectall_trac'
     658#endif
     659        CALL condiso_liq_ice_vectall_trac(xt_k(1,1),qnk(1), &
     660              clw_k(1),tg_k(1), &
     661              zfice(1),zxtice(1,1),zxtliq(1,1),len)
     662#endif
     663       DO i=1,len
     664         DO ixt = 1, ntraciso
     665           xtclw(ixt,i,icbs(i))=  zxtice(ixt,i)+zxtliq(ixt,i)
    648666           xtclw(ixt,i,icbs(i))=max(0.0,xtclw(ixt,i,icbs(i)))
    649          enddo !do ixt=1,niso   
    650        enddo  !do i=1,len       
    651 
    652 #ifdef ISOVERIF
    653             write(*,*) 'cv30_routine undilute 1 598: apres condiso'
    654          
    655           if (iso_eau.gt.0) then
    656             do i=1,len
    657               call iso_verif_egalite_choix(xtclw(iso_eau,i,icbs(i)), &
    658      &         clw(i,icbs(i)),'cv30_routines 577',errmax,errmaxrel)
     667         enddo !do ixt=1,niso
     668       enddo  !do i=1,len
     669
     670#ifdef ISOVERIF
     671            WRITE(*,*) 'cv30_routine undilute 1 598: apres condiso'
     672
     673          IF (iso_eau.gt.0) THEN
     674            DO i=1,len
     675              CALL iso_verif_egalite_choix(xtclw(iso_eau,i,icbs(i)), &
     676               clw(i,icbs(i)),'cv30_routines 577',errmax,errmaxrel)
    659677            enddo !do i=1,len
    660           endif !if (iso_eau.gt.0) then
    661 #ifdef ISOTRAC   
    662         do i=1,len
    663            call iso_verif_traceur(xtclw(1,i,k),'cv30_routines 603')
     678          endif !if (iso_eau.gt.0) THEN
     679#ifdef ISOTRAC
     680        DO i=1,len
     681           CALL iso_verif_traceur(xtclw(1,i,k),'cv30_routines 603')
    664682        enddo
    665683#endif
    666          
     684
    667685#endif
    668686#endif
    … …  
    716734    denom = 243.5 + tc
    717735    denom = max(denom, 1.0) ! convect3
    718     ! ori          if(tc.ge.0.0)then
     736    ! ori          IF(tc.ge.0.0)THEN
    719737    es = 6.112*exp(17.67*tc/denom)
    720738    ! ori          else
    … …  
    738756    denom = 243.5 + tc
    739757    denom = max(denom, 1.0) ! convect3
    740     ! ori          if(tc.ge.0.0)then
     758    ! ori          IF(tc.ge.0.0)THEN
    741759    es = 6.112*exp(17.67*tc/denom)
    742760    ! ori          else
    … …  
    772790
    773791#ifdef ISO
    774         do i=1,len
     792        DO i=1,len
    775793         zfice(i) = 1.0-(t(i,icb(i)+1)-pxtice)/(pxtmelt-pxtice)
    776794         zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
    777 !         call calcul_zfice(tp(i,icb(i)+1),zfice)
     795!         CALL calcul_zfice(tp(i,icb(i)+1),zfice)
    778796        enddo !do i=1,len
    779         do i=1,len
     797        DO i=1,len
    780798         clw_k(i)=clw(i,icb(i)+1)
    781799         tg_k(i)=t(i,icb(i)+1)
    782800#ifdef ISOVERIF
    783         call iso_verif_positif(tg_k(i)-Tmin_verif,'cv30_routines 750')   
    784 #endif         
    785          do ixt=1,ntraciso
    786             xt_k(ixt,i)=xt(ixt,i,nk(i)) 
    787           enddo   
     801        CALL iso_verif_positif(tg_k(i)-Tmin_verif,'cv30_routines 750')
     802#endif
     803         DO ixt=1,ntraciso
     804            xt_k(ixt,i)=xt(ixt,i,nk(i))
     805          enddo
    788806        enddo !do i=1,len
    789 #ifdef ISOVERIF 
    790         write(*,*) 'cv30_routines 739: avant condiso'
    791         if (iso_HDO.gt.0) then           
    792          do i=1,len
    793            call iso_verif_aberrant(xt_k(iso_hdo,i)/qnk(i), &
    794      &            'cv30_routines 725')
    795          enddo       
    796         endif !if (iso_HDO.gt.0) then
    797 #ifdef ISOTRAC   
    798         do i=1,len
    799            call iso_verif_traceur(xtclw(1,i,k),'cv30_routines 738')
     807#ifdef ISOVERIF
     808        WRITE(*,*) 'cv30_routines 739: avant condiso'
     809        IF (iso_HDO.gt.0) THEN
     810         DO i=1,len
     811           CALL iso_verif_aberrant(xt_k(iso_hdo,i)/qnk(i), &
     812                  'cv30_routines 725')
     813         enddo
     814        endif !if (iso_HDO.gt.0) THEN
     815#ifdef ISOTRAC
     816        DO i=1,len
     817           CALL iso_verif_traceur(xtclw(1,i,k),'cv30_routines 738')
    800818        enddo
    801 #endif       
    802 #endif       
    803         call condiso_liq_ice_vectall(xt_k(1,1),qnk(1), &
    804      &        clw_k(1),tg_k(1), &
    805      &        zfice(1),zxtice(1,1),zxtliq(1,1),len)
     819#endif
     820#endif
     821        CALL condiso_liq_ice_vectall(xt_k(1,1),qnk(1), &
     822              clw_k(1),tg_k(1), &
     823              zfice(1),zxtice(1,1),zxtliq(1,1),len)
    806824#ifdef ISOTRAC
    807         call condiso_liq_ice_vectall_trac(xt_k(1,1),qnk(1), &
    808      &        clw_k(1),tg_k(1), &
    809      &        zfice(1),zxtice(1,1),zxtliq(1,1),len)
    810 #endif
    811         do i=1,len
    812          do ixt = 1, ntraciso
    813           xtclw(ixt,i,icb(i)+1)=zxtice(ixt,i)+zxtliq(ixt,i)         
     825        CALL condiso_liq_ice_vectall_trac(xt_k(1,1),qnk(1), &
     826              clw_k(1),tg_k(1), &
     827              zfice(1),zxtice(1,1),zxtliq(1,1),len)
     828#endif
     829        DO i=1,len
     830         DO ixt = 1, ntraciso
     831          xtclw(ixt,i,icb(i)+1)=zxtice(ixt,i)+zxtliq(ixt,i)
    814832          xtclw(ixt,i,icb(i)+1)=max(0.0,xtclw(ixt,i,icb(i)+1))
    815833         enddo !do ixt = 1, niso
    816834        enddo !do i=1,len
    817835
    818 #ifdef ISOVERIF           
    819 !write(*,*) 'DEBUG ISO B'
    820           do i=1,len
    821             if (iso_eau.gt.0) then
    822              call iso_verif_egalite_choix(xtclw(iso_eau,i,icb(i)+1), &
    823      &           clw(i,icb(i)+1),'cv30_routines 708',errmax,errmaxrel)
    824             endif ! if (iso_eau.gt.0) then
    825 #ifdef ISOTRAC   
    826            call iso_verif_traceur(xtclw(1,i,icb(i)+1), &
    827      &           'cv30_routines 760')
    828 #endif           
     836#ifdef ISOVERIF
     837!WRITE(*,*) 'DEBUG ISO B'
     838          DO i=1,len
     839            IF (iso_eau.gt.0) THEN
     840             CALL iso_verif_egalite_choix(xtclw(iso_eau,i,icb(i)+1), &
     841                 clw(i,icb(i)+1),'cv30_routines 708',errmax,errmaxrel)
     842            endif ! if (iso_eau.gt.0) THEN
     843#ifdef ISOTRAC
     844           CALL iso_verif_traceur(xtclw(1,i,icb(i)+1), &
     845                 'cv30_routines 760')
     846#endif
    829847          enddo !do i=1,len
    830             !write(*,*) 'FIN DEBUG ISO B'
    831 #endif 
    832 #endif
    833 
    834   RETURN
     848            !WRITE(*,*) 'FIN DEBUG ISO B'
     849#endif
     850#endif
     851
     852
    835853END SUBROUTINE cv30_undilute1
    836854
    … …  
    854872  ! -------------------------------------------------------------------
    855873
    856   include "cv30param.h"
     874
    857875
    858876  ! input:
    … …  
    901919  ! oct3       ath  = th(i,icb(i)-1) - dttrig
    902920  ! oct3
    903   ! oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
     921  ! oct3       if (tdif.lt.dtcrit .OR. ath.gt.ath1) THEN
    904922  ! oct3         do 60 k=1,nl
    905923  ! oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
    … …  
    909927  ! oct3         iflag(i)=4 ! pour version vectorisee
    910928  ! oct3c convect3         iflag(i)=0
    911   ! oct3cccc         return
     929  ! oct3cccc         RETURN
    912930  ! oct3       endif
    913931  ! oct3
    … …  
    936954  ! fin oct3 --
    937955
    938   RETURN
     956
    939957END SUBROUTINE cv30_trigger
    940958
    … …  
    943961    th1, tra1, h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, sig1, w01, &
    944962    iflag, nk, icb, icbs, plcl, tnk, qnk, gznk, pbase, buoybase, t, q, qs, u, &
    945     v, gz, th, tra, h, lv, cpn, p, ph, tv, tp, tvp, clw, sig, w0 & 
    946 #ifdef ISO
    947      &    ,xtnk1,xt1,xtclw1 &
    948      &    ,xtnk,xt,xtclw &
    949 #endif
    950      &    )
     963    v, gz, th, tra, h, lv, cpn, p, ph, tv, tp, tvp, clw, sig, w0 &
     964#ifdef ISO
     965          ,xtnk1,xt1,xtclw1 &
     966          ,xtnk,xt,xtclw &
     967#endif
     968          )
    951969  USE print_control_mod, ONLY: lunout
    952970#ifdef ISO
    953     use infotrac_phy, ONLY: ntraciso=>ntiso
    954     use isotopes_mod, ONLY: essai_convergence, iso_eau,iso_HDO
    955 #ifdef ISOVERIF
    956     use isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif, &
     971    USE infotrac_phy, ONLY: ntraciso=>ntiso
     972    USE isotopes_mod, ONLY: essai_convergence, iso_eau,iso_HDO
     973#ifdef ISOVERIF
     974    USE isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif, &
    957975        iso_verif_egalite_choix, iso_verif_noNaN,iso_verif_aberrant, &
    958976        iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
    … …  
    963981  IMPLICIT NONE
    964982
    965   include "cv30param.h"
     983
    966984
    967985  ! inputs:
    … …  
    979997#ifdef ISO
    980998      !integer niso
    981       real xt1(ntraciso,len,nd), xtclw1(ntraciso,len,nd)
    982       real xtnk1(ntraciso,len)
     999      REAL xt1(ntraciso,len,nd), xtclw1(ntraciso,len,nd)
     1000      REAL xtnk1(ntraciso,len)
    9831001#endif
    9841002
    … …  
    9961014  REAL tra(nloc, nd, ntra)
    9971015#ifdef ISO
    998       real xt(ntraciso,nloc,nd), xtclw(ntraciso,nloc,nd)
    999       real xtnk(ntraciso,nloc)
     1016      REAL xt(ntraciso,nloc,nd), xtclw(ntraciso,nloc,nd)
     1017      REAL xtnk(ntraciso,nloc)
    10001018#endif
    10011019
    … …  
    10031021  INTEGER i, k, nn, j
    10041022#ifdef ISO
    1005       integer ixt
     1023      INTEGER ixt
    10061024#endif
    10071025
    … …  
    10111029#ifdef ISO
    10121030        ! initialisation des champs compresses:
    1013         do k=1,nd
    1014           do i=1,nloc
    1015             if (essai_convergence) then
     1031        DO k=1,nd
     1032          DO i=1,nloc
     1033            IF (essai_convergence) THEN
    10161034            else
    10171035              q(i,k)=0.0
    10181036              clw(i,k)=0.0 ! mise en commentaire le 5 avril pour verif
    10191037!            convergence
    1020             endif  !f (negation(essai_convergence)) then
    1021             do ixt=1,ntraciso
     1038            endif  !f (negation(essai_convergence)) THEN
     1039            DO ixt=1,ntraciso
    10221040              xt(ixt,i,k)=0.0
    10231041              xtclw(ixt,i,k)=0.0
    1024             enddo !do ixt=1,niso         
     1042            enddo !do ixt=1,niso
    10251043          enddo !do i=1,len
    10261044        enddo !do k=1,nd
    1027 !        write(*,*) 'q(1,1),xt(iso_eau,1,1)=',q(1,1),xt(iso_eau,1,1)
     1045!        WRITE(*,*) 'q(1,1),xt(iso_eau,1,1)=',q(1,1),xt(iso_eau,1,1)
    10281046#endif
    10291047
    … …  
    10521070        th(nn, k) = th1(i, k)
    10531071#ifdef ISO
    1054         do ixt = 1, ntraciso
     1072        DO ixt = 1, ntraciso
    10551073           xt(ixt,nn,k)=xt1(ixt,i,k)
    10561074           xtclw(ixt,nn,k)=xtclw1(ixt,i,k)
    10571075        enddo
    1058 !        write(*,*) 'nn,i,k,q(nn,k),xt(iso_eau,nn,k)=', &
     1076!        WRITE(*,*) 'nn,i,k,q(nn,k),xt(iso_eau,nn,k)=', &
    10591077!                & nn,i,k,q(nn, k),xt(ixt,nn,k)
    10601078#endif
    … …  
    10671085  ! nn=0
    10681086  ! do 101 i=1,len
    1069   ! if(iflag1(i).eq.0)then
     1087  ! IF(iflag1(i).EQ.0)THEN
    10701088  ! nn=nn+1
    10711089  ! tra(nn,k,j)=tra1(i,k,j)
    1072   ! endif
     1090  ! END IF
    10731091  ! 101  continue
    10741092  ! 111  continue
    … …  
    10961114      iflag(nn) = iflag1(i)
    10971115#ifdef ISO
    1098       do ixt=1,ntraciso
     1116      DO ixt=1,ntraciso
    10991117        xtnk(ixt,nn) = xtnk1(ixt,i)
    11001118      enddo
    … …  
    11051123#ifdef ISO
    11061124#ifdef ISOVERIF
    1107        if (iso_eau.gt.0) then
    1108         do k = 1, nd
    1109          do i = 1, nloc 
    1110         !write(*,*) 'i,k=',i,k                 
    1111         call iso_verif_egalite_choix(xtclw(iso_eau,i,k),clw(i,k), &
    1112      &            'compress 973',errmax,errmaxrel)
    1113         call iso_verif_egalite_choix(xt(iso_eau,i,k),q(i,k), &
    1114      &            'compress 975',errmax,errmaxrel)
     1125       IF (iso_eau.gt.0) THEN
     1126        DO k = 1, nd
     1127         DO i = 1, nloc
     1128        !WRITE(*,*) 'i,k=',i,k
     1129        CALL iso_verif_egalite_choix(xtclw(iso_eau,i,k),clw(i,k), &
     1130                  'compress 973',errmax,errmaxrel)
     1131        CALL iso_verif_egalite_choix(xt(iso_eau,i,k),q(i,k), &
     1132                  'compress 975',errmax,errmaxrel)
    11151133         enddo
    11161134        enddo
    1117        endif !if (iso_eau.gt.0) then
    1118        do k = 1, nd
    1119          do i = 1, nn
    1120            call iso_verif_positif(q(i,k),'compress 1004')         
     1135       endif !if (iso_eau.gt.0) THEN
     1136       DO k = 1, nd
     1137         DO i = 1, nn
     1138           CALL iso_verif_positif(q(i,k),'compress 1004')
    11211139         enddo
    1122        enddo 
    1123 #endif
    1124 #endif
    1125 
    1126 
    1127   RETURN
     1140       enddo
     1141#endif
     1142#endif
     1143
     1144
     1145
    11281146END SUBROUTINE cv30_compress
    11291147
    … …  
    11321150    ep, sigp, buoy &
    11331151#ifdef ISO
    1134      &   ,xtnk,xt,xtclw &
    1135 #endif
    1136      &   )
     1152         ,xtnk,xt,xtclw &
     1153#endif
     1154         )
    11371155    ! epmax_cape: ajout arguments
    1138 #ifdef ISO
    1139 use infotrac_phy, ONLY: ntraciso=>ntiso
     1156USE conema3_mod_h
     1157#ifdef ISO
     1158USE infotrac_phy, ONLY: ntraciso=>ntiso
    11401159USE isotopes_mod, ONLY: pxtmelt,pxtice,pxtmin,pxtmax,cond_temp_env, iso_eau,iso_HDO
    11411160USE isotopes_routines_mod, ONLY: condiso_liq_ice_vectall
    … …  
    11471166#endif
    11481167#ifdef ISOVERIF
    1149     use isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif,Tmax_verif, &
     1168    USE isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif,Tmax_verif, &
    11501169        iso_verif_egalite_choix, iso_verif_noNaN,iso_verif_aberrant, &
    11511170        iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
    … …  
    11541173#endif
    11551174#endif
    1156   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    1157           , clmci, eps, epsi, epsim1, ginv, hrd, grav
     1175USE cvthermo_mod_h
    11581176  IMPLICIT NONE
    11591177
    … …  
    11731191  ! - vertical profile of buoyancy computed here (use of buoybase)
    11741192  ! - the determination of inb is different
    1175   ! - no inb1, only inb in output
     1193  ! - no inb1, ONLY inb in output
    11761194  ! ---------------------------------------------------------------------
    1177 
    1178   include "cv30param.h"
    1179   include "conema3.h"
    11801195
    11811196  ! inputs:
    … …  
    12021217
    12031218#ifdef ISO
    1204       real xt(ntraciso,nloc,nd), xtclw(ntraciso,nloc,nd)
    1205       real xtnk(ntraciso,nloc)
     1219      REAL xt(ntraciso,nloc,nd), xtclw(ntraciso,nloc,nd)
     1220      REAL xtnk(ntraciso,nloc)
    12061221!      real xtep(ntraciso,nloc,nd) ! le 7 mai: on supprime xtep, car pas besoin
    12071222!      la chute de precip ne fractionne pas.
    1208       integer ixt
    1209       real zfice(nloc),zxtliq(ntraciso,nloc),zxtice(ntraciso,nloc)
    1210       real clw_k(nloc),tg_k(nloc)
    1211 #ifdef ISOVERIF     
    1212       real qg_save(nloc,nd) ! inout
     1223      INTEGER ixt
     1224      REAL zfice(nloc),zxtliq(ntraciso,nloc),zxtice(ntraciso,nloc)
     1225      REAL clw_k(nloc),tg_k(nloc)
     1226#ifdef ISOVERIF
     1227      REAL qg_save(nloc,nd) ! inout
    12131228      !integer iso_verif_positif_nostop
    1214 #endif     
     1229#endif
    12151230#endif
    12161231
    … …  
    12491264  DO k = minorig + 1, nl
    12501265    DO i = 1, ncum
    1251       ! ori         if(k.ge.(icb(i)+1))then
     1266      ! ori        IF(k.ge.(icb(i)+1))THEN
    12521267      IF (k>=(icbs(i)+1)) THEN ! convect3
    12531268        tg = t(i, k)
    12541269        qg = qs(i, k)
    1255         ! debug       alv=lv0-clmcpv*(t(i,k)-t0)
     1270        ! debug          alv=lv0-clmcpv*(t(i,k)-t0)
    12561271        alv = lv0 - clmcpv*(t(i,k)-273.15)
    12571272
    12581273        ! First iteration.
    12591274
    1260         ! ori          s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
     1275        ! ori           s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
    12611276        s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
    12621277          +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
    12631278        s = 1./s
    1264         ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
     1279        ! ori           ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
    12651280        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
    12661281        tg = tg + s*(ah0(i)-ahg)
    1267         ! ori          tg=max(tg,35.0)
    1268         ! debug        tc=tg-t0
     1282        ! ori           tg=max(tg,35.0)
     1283        ! debug           tc=tg-t0
    12691284        tc = tg - 273.15
    12701285        denom = 243.5 + tc
    12711286        denom = max(denom, 1.0) ! convect3
    1272         ! ori          if(tc.ge.0.0)then
     1287        ! ori           IF(tc.ge.0.0)THEN
    12731288        es = 6.112*exp(17.67*tc/denom)
    1274         ! ori          else
    1275         ! ori                   es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    1276         ! ori          endif
     1289        ! ori           else
     1290        ! ori            es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     1291        ! ori           endif
    12771292        qg = eps*es/(p(i,k)-es*(1.-eps))
    12781293!        qg=max(0.0,qg) ! C Risi
    … …  
    12801295        ! Second iteration.
    12811296
    1282         ! ori          s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
    1283         ! ori          s=1./s
    1284         ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
     1297        ! ori           s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
     1298        ! ori           s=1./s
     1299        ! ori           ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
    12851300        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
    12861301        tg = tg + s*(ah0(i)-ahg)
    1287         ! ori          tg=max(tg,35.0)
    1288         ! debug        tc=tg-t0
     1302        ! ori           tg=max(tg,35.0)
     1303        ! debug           tc=tg-t0
    12891304        tc = tg - 273.15
    12901305        denom = 243.5 + tc
    12911306        denom = max(denom, 1.0) ! convect3
    1292         ! ori          if(tc.ge.0.0)then
     1307        ! ori           IF(tc.ge.0.0)THEN
    12931308        es = 6.112*exp(17.67*tc/denom)
    1294         ! ori          else
    1295         ! ori                   es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
    1296         ! ori          endif
     1309        ! ori           else
     1310        ! ori            es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
     1311        ! ori           endif
    12971312        qg = eps*es/(p(i,k)-es*(1.-eps))
    12981313!        qg=max(0.0,qg) ! C Risi
    12991314
    1300         ! debug        alv=lv0-clmcpv*(t(i,k)-t0)
     1315        ! debug           alv=lv0-clmcpv*(t(i,k)-t0)
    13011316        alv = lv0 - clmcpv*(t(i,k)-273.15)
    1302         ! print*,'cpd dans convect2 ',cpd
    1303         ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
    1304         ! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
     1317        ! PRINT*,'cpd dans convect2 ',cpd
     1318        ! PRINT*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
     1319        ! PRINT*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
    13051320
    13061321        ! ori c approximation here:
    … …  
    13221337#ifdef ISO
    13231338       ! calcul de zfice
    1324        do i=1,ncum
     1339       DO i=1,ncum
    13251340          zfice(i) = 1.0-(t(i,k)-pxtice)/(pxtmelt-pxtice)
    1326           zfice(i) = MIN(MAX(zfice(i),0.0),1.0)         
     1341          zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
    13271342       enddo
    1328        do i=1,ncum
     1343       DO i=1,ncum
    13291344         clw_k(i)=clw(i,k)
    13301345         tg_k(i)=t(i,k)
    13311346       enddo !do i=1,ncum
    13321347#ifdef ISOVERIF
    1333         !write(*,*) 'cv30_routine 1259: avant condiso'
    1334         if (iso_HDO.gt.0) then           
    1335          do i=1,ncum
    1336            call iso_verif_aberrant(xtnk(iso_hdo,i)/qnk(i), &
    1337      &            'cv30_routines 1231')
    1338          enddo       
    1339         endif !if (iso_HDO.gt.0) then
    1340         if (iso_eau.gt.0) then           
    1341          do i=1,ncum
    1342            call iso_verif_egalite(xtnk(iso_eau,i),qnk(i), &
    1343      &            'cv30_routines 1373')
    1344          enddo       
    1345         endif !if (iso_HDO.gt.0) then
    1346         do i=1,ncum
    1347          if ((iso_verif_positif_nostop(qnk(i)-clw_k(i), &
    1348      &       'cv30_routines 1275').eq.1).or. &
    1349      &       (iso_verif_positif_nostop(tg_k(i)-Tmin_verif, &
    1350      &       'cv30_routines 1297a').eq.1).or.  &
    1351      &       (iso_verif_positif_nostop(Tmax_verif-tg_k(i), &
    1352      &       'cv30_routines 1297b').eq.1)) then
    1353           write(*,*) 'i,k,qnk,clw_k=',i,k,qnk(i),clw_k(i)
    1354           write(*,*) 'tg,t,qg=',tg_k(i),t(i,k),qg_save(i,k)
    1355           write(*,*) 'icbs(i)=',icbs(i)
     1348        !WRITE(*,*) 'cv30_routine 1259: avant condiso'
     1349        IF (iso_HDO.gt.0) THEN
     1350         DO i=1,ncum
     1351           CALL iso_verif_aberrant(xtnk(iso_hdo,i)/qnk(i), &
     1352                  'cv30_routines 1231')
     1353         enddo
     1354        endif !if (iso_HDO.gt.0) THEN
     1355        IF (iso_eau.gt.0) THEN
     1356         DO i=1,ncum
     1357           CALL iso_verif_egalite(xtnk(iso_eau,i),qnk(i), &
     1358                  'cv30_routines 1373')
     1359         enddo
     1360        endif !if (iso_HDO.gt.0) THEN
     1361        DO i=1,ncum
     1362         IF ((iso_verif_positif_nostop(qnk(i)-clw_k(i), &
     1363             'cv30_routines 1275').EQ.1).OR. &
     1364             (iso_verif_positif_nostop(tg_k(i)-Tmin_verif, &
     1365             'cv30_routines 1297a').EQ.1).OR.  &
     1366             (iso_verif_positif_nostop(Tmax_verif-tg_k(i), &
     1367             'cv30_routines 1297b').EQ.1)) THEN
     1368          WRITE(*,*) 'i,k,qnk,clw_k=',i,k,qnk(i),clw_k(i)
     1369          WRITE(*,*) 'tg,t,qg=',tg_k(i),t(i,k),qg_save(i,k)
     1370          WRITE(*,*) 'icbs(i)=',icbs(i)
    13561371          stop
    13571372         endif ! if ((iso_verif_positif_nostop
    1358         enddo !do i=1,ncum   
    1359 #ifdef ISOTRAC   
    1360         do i=1,ncum
    1361            call iso_verif_traceur(xtnk(1,i),'cv30_routines 1251') 
    13621373        enddo !do i=1,ncum
    1363 #endif       
    1364 #endif       
    1365         call condiso_liq_ice_vectall(xtnk(1,1),qnk(1), &
    1366      &        clw_k(1),tg_k(1), &
    1367      &        zfice(1),zxtice(1,1),zxtliq(1,1),ncum)
    13681374#ifdef ISOTRAC
    1369 #ifdef ISOVERIF
    1370         write(*,*) 'cv30_routines 1283: condiso pour traceurs'
    1371 #endif
    1372         call condiso_liq_ice_vectall_trac(xtnk(1,1),qnk(1), &
    1373      &        clw_k(1),tg_k(1), &
    1374      &        zfice(1),zxtice(1,1),zxtliq(1,1),ncum)       
    1375 #endif
    1376         do i=1,ncum
    1377          do ixt=1,ntraciso
     1375        DO i=1,ncum
     1376           CALL iso_verif_traceur(xtnk(1,i),'cv30_routines 1251')
     1377        enddo !do i=1,ncum
     1378#endif
     1379#endif
     1380        CALL condiso_liq_ice_vectall(xtnk(1,1),qnk(1), &
     1381              clw_k(1),tg_k(1), &
     1382              zfice(1),zxtice(1,1),zxtliq(1,1),ncum)
     1383#ifdef ISOTRAC
     1384#ifdef ISOVERIF
     1385        WRITE(*,*) 'cv30_routines 1283: condiso pour traceurs'
     1386#endif
     1387        CALL condiso_liq_ice_vectall_trac(xtnk(1,1),qnk(1), &
     1388              clw_k(1),tg_k(1), &
     1389              zfice(1),zxtice(1,1),zxtliq(1,1),ncum)
     1390#endif
     1391        DO i=1,ncum
     1392         DO ixt=1,ntraciso
    13781393          xtclw(ixt,i,k)=zxtice(ixt,i)+zxtliq(ixt,i)
    13791394          xtclw(ixt,i,k)=max(0.0,xtclw(ixt,i,k))
    … …  
    13811396        enddo !do i=1,ncum
    13821397#ifdef ISOVERIF
    1383         if (iso_eau.gt.0) then
    1384           do i=1,ncum       
    1385            call iso_verif_egalite_choix(xtclw(iso_eau,i,k), &
    1386      &          clw(i,k),'cv30_routines 1223',errmax,errmaxrel)
     1398        IF (iso_eau.gt.0) THEN
     1399          DO i=1,ncum
     1400           CALL iso_verif_egalite_choix(xtclw(iso_eau,i,k), &
     1401                clw(i,k),'cv30_routines 1223',errmax,errmaxrel)
    13871402          enddo
    1388         endif !if (iso_eau.gt.0) then
    1389 #ifdef ISOTRAC   
    1390         do i=1,ncum
    1391            call iso_verif_traceur(xtclw(1,i,k),'cv30_routines 1275')
     1403        endif !if (iso_eau.gt.0) THEN
     1404#ifdef ISOTRAC
     1405        DO i=1,ncum
     1406           CALL iso_verif_traceur(xtclw(1,i,k),'cv30_routines 1275')
    13921407        enddo
    1393 #endif       
    1394 #endif       
     1408#endif
     1409#endif
    13951410#endif
    13961411  END DO
    … …  
    14101425      ep(i, k) = amin1(ep(i,k), epmax)
    14111426      sigp(i, k) = spfac
    1412       ! ori          if(k.ge.(nk(i)+1))then
     1427      ! ori          IF(k.ge.(nk(i)+1))THEN
    14131428      ! ori            tca=tp(i,k)-t0
    1414       ! ori            if(tca.ge.0.0)then
     1429      ! ori            IF(tca.ge.0.0)THEN
    14151430      ! ori              elacrit=elcrit
    14161431      ! ori            else
    … …  
    14361451  ! ori      do 340 k=minorig+1,nl
    14371452  ! ori        do 330 i=1,ncum
    1438   ! ori        if(k.ge.(icb(i)+1))then
     1453  ! ori        IF(k.ge.(icb(i)+1))THEN
    14391454  ! ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
    1440   ! oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
    1441   ! oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
     1455  ! oric         PRINT*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
     1456  ! oric         PRINT*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
    14421457  ! ori        endif
    14431458  ! ori 330    continue
    … …  
    15131528  ! do 530 k=minorig+1,nl-1
    15141529  ! do 520 i=1,ncum
    1515   ! if(k.ge.(icb(i)+1))then
     1530  ! IF(k.ge.(icb(i)+1))THEN
    15161531  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
    15171532  ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
    15181533  ! cape(i)=cape(i)+by
    1519   ! if(by.ge.0.0)inb1(i)=k+1
    1520   ! if(cape(i).gt.0.0)then
     1534  ! IF(by.ge.0.0)inb1(i)=k+1
     1535  ! IF(cape(i).gt.0.0)THEN
    15211536  ! inb(i)=k+1
    15221537  ! capem(i)=cape(i)
    1523   ! endif
    1524   ! endif
     1538  ! END IF
     1539  ! END IF
    15251540  ! 520    continue
    15261541  ! 530  continue
    … …  
    15371552  ! K Emanuel fix
    15381553
    1539   ! call zilch(byp,ncum)
     1554  ! CALL zilch(byp,ncum)
    15401555  ! do 530 k=minorig+1,nl-1
    15411556  ! do 520 i=1,ncum
    1542   ! if(k.ge.(icb(i)+1))then
     1557  ! IF(k.ge.(icb(i)+1))THEN
    15431558  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
    15441559  ! cape(i)=cape(i)+by
    1545   ! if(by.ge.0.0)inb1(i)=k+1
    1546   ! if(cape(i).gt.0.0)then
     1560  ! IF(by.ge.0.0)inb1(i)=k+1
     1561  ! IF(cape(i).gt.0.0)THEN
    15471562  ! inb(i)=k+1
    15481563  ! capem(i)=cape(i)
    15491564  ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
    1550   ! endif
    1551   ! endif
     1565  ! END IF
     1566  ! END IF
    15521567  ! 520    continue
    15531568  ! 530  continue
    … …  
    15641579  ! J Teixeira fix
    15651580
    1566   ! ori      call zilch(byp,ncum)
     1581  ! ori      CALL zilch(byp,ncum)
    15671582  ! ori      do 515 i=1,ncum
    1568   ! ori        lcape(i)=.true.
     1583  ! ori        lcape(i)=.TRUE.
    15691584  ! ori 515  continue
    15701585  ! ori      do 530 k=minorig+1,nl-1
    15711586  ! ori        do 520 i=1,ncum
    1572   ! ori          if(cape(i).lt.0.0)lcape(i)=.false.
    1573   ! ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
     1587  ! ori          IF(cape(i).lt.0.0)lcape(i)=.FALSE.
     1588  ! ori          if((k.ge.(icb(i)+1)).AND.lcape(i))THEN
    15741589  ! ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
    15751590  ! ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
    15761591  ! ori            cape(i)=cape(i)+by
    1577   ! ori            if(by.ge.0.0)inb1(i)=k+1
    1578   ! ori            if(cape(i).gt.0.0)then
     1592  ! ori            IF(by.ge.0.0)inb1(i)=k+1
     1593  ! ori            IF(cape(i).gt.0.0)THEN
    15791594  ! ori              inb(i)=k+1
    15801595  ! ori              capem(i)=cape(i)
    … …  
    16151630  END DO
    16161631
    1617   RETURN
     1632
    16181633END SUBROUTINE cv30_undilute2
    16191634
    16201635SUBROUTINE cv30_closure(nloc, ncum, nd, icb, inb, pbase, p, ph, tv, buoy, &
    16211636    sig, w0, cape, m)
    1622   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    1623           , clmci, eps, epsi, epsim1, ginv, hrd, grav
     1637  USE cvthermo_mod_h
     1638
    16241639  IMPLICIT NONE
    16251640
    … …  
    16291644  ! vectorization: S. Bony
    16301645  ! ===================================================================
    1631 
    1632   include "cv30param.h"
    16331646
    16341647  ! input:
    … …  
    16971710  END DO
    16981711
    1699   ! !      if(inb.lt.(nl-1))then
    1700   ! !         do 85 i=inb+1,nl-1
    1701   ! !            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
    1702   ! !     1              abs(buoy(inb))
    1703   ! !            sig(i)=amax1(sig(i),0.0)
    1704   ! !            w0(i)=beta*w0(i)
    1705   ! !   85    continue
    1706   ! !      end if
    1707 
    1708   ! !      do 87 i=1,icb
    1709   ! !         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
    1710   ! !         sig(i)=amax1(sig(i),0.0)
    1711   ! !         w0(i)=beta*w0(i)
    1712   ! !   87 continue
     1712  !      IF(inb.lt.(nl-1))THEN
     1713  !         do 85 i=inb+1,nl-1
     1714  !            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
     1715  !     1              abs(buoy(inb))
     1716  !            sig(i)=amax1(sig(i),0.0)
     1717  !            w0(i)=beta*w0(i)
     1718  !   85    continue
     1719  !      end if
     1720
     1721  !      do 87 i=1,icb
     1722  !         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
     1723  !         sig(i)=amax1(sig(i),0.0)
     1724  !         w0(i)=beta*w0(i)
     1725  !   87 continue
    17131726
    17141727  ! -------------------------------------------------------------
    … …  
    17931806
    17941807
    1795   ! !      cape=0.0
    1796   ! !      do 98 i=icb+1,inb
    1797   ! !         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
    1798   ! !         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
    1799   ! !         dcape=rrd*buoy(i-1)*deltap/p(i-1)
    1800   ! !         dlnp=deltap/p(i-1)
    1801   ! !         cape=amax1(0.0,cape)
    1802   ! !         sigold=sig(i)
    1803 
    1804   ! !         dtmin=100.0
    1805   ! !         do 97 j=icb,i-1
    1806   ! !            dtmin=amin1(dtmin,buoy(j))
    1807   ! !   97    continue
    1808 
    1809   ! !         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
    1810   ! !         sig(i)=amax1(sig(i),0.0)
    1811   ! !         sig(i)=amin1(sig(i),0.01)
    1812   ! !         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
    1813   ! !         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
    1814   ! !         amu=0.5*(sig(i)+sigold)*w
    1815   ! !         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
    1816   ! !         w0(i)=w
    1817   ! !   98 continue
    1818   ! !      w0(icb)=0.5*w0(icb+1)
    1819   ! !      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
    1820   ! !      sig(icb)=sig(icb+1)
    1821   ! !      sig(icb-1)=sig(icb)
    1822 
    1823   RETURN
     1808  !      cape=0.0
     1809  !      do 98 i=icb+1,inb
     1810  !         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
     1811  !         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
     1812  !         dcape=rrd*buoy(i-1)*deltap/p(i-1)
     1813  !         dlnp=deltap/p(i-1)
     1814  !         cape=amax1(0.0,cape)
     1815  !         sigold=sig(i)
     1816
     1817  !         dtmin=100.0
     1818  !         do 97 j=icb,i-1
     1819  !            dtmin=amin1(dtmin,buoy(j))
     1820  !   97    continue
     1821
     1822  !         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
     1823  !         sig(i)=amax1(sig(i),0.0)
     1824  !         sig(i)=amin1(sig(i),0.01)
     1825  !         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
     1826  !         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
     1827  !         amu=0.5*(sig(i)+sigold)*w
     1828  !         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
     1829  !         w0(i)=w
     1830  !   98 continue
     1831  !      w0(icb)=0.5*w0(icb+1)
     1832  !      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
     1833  !      sig(icb)=sig(icb+1)
     1834  !      sig(icb-1)=sig(icb)
     1835
     1836
    18241837END SUBROUTINE cv30_closure
    18251838
    … …  
    18281841    vent, sij, elij, ments, qents, traent &
    18291842#ifdef ISO
    1830      &                     ,xt,xtnk,xtclw &
    1831      &                     ,xtent,xtelij &
    1832 #endif
    1833      &     )
    1834 
    1835 #ifdef ISO
    1836 use infotrac_phy, ONLY: ntraciso=>ntiso,niso,itZonIso
     1843                           ,xt,xtnk,xtclw &
     1844                           ,xtent,xtelij &
     1845#endif
     1846           )
     1847
     1848#ifdef ISO
     1849USE infotrac_phy, ONLY: ntraciso=>ntiso,niso,itZonIso
    18371850USE isotopes_mod, ONLY: pxtmelt,pxtice,pxtmin,pxtmax, iso_eau,iso_HDO, &
    18381851        ridicule
    18391852USE isotopes_routines_mod, ONLY: condiso_liq_ice_vectall
    18401853#ifdef ISOVERIF
    1841     use isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif,deltalim, &
     1854    USE isotopes_verif_mod, ONLY: errmax,errmaxrel,Tmin_verif,deltalim, &
    18421855        iso_verif_egalite_choix,iso_verif_aberrant_choix, iso_verif_noNaN, &
    18431856        iso_verif_aberrant, &
    … …  
    18471860#endif
    18481861#ifdef ISOTRAC
    1849     use isotrac_mod, only: option_tmin,option_traceurs,seuil_tag_tmin, &
     1862    USE isotrac_mod, ONLY: option_tmin,option_traceurs,seuil_tag_tmin, &
    18501863&       option_cond,index_zone,izone_cond,index_iso
    1851     use isotrac_routines_mod, only: iso_recolorise_condensation
    1852     use isotopes_routines_mod, only: condiso_liq_ice_vectall_trac
    1853 #ifdef ISOVERIF
    1854     use isotopes_verif_mod, ONLY: iso_verif_trac17_q_deltad,iso_verif_traceur, &
     1864    USE isotrac_routines_mod, ONLY: iso_recolorise_condensation
     1865    USE isotopes_routines_mod, ONLY: condiso_liq_ice_vectall_trac
     1866#ifdef ISOVERIF
     1867    USE isotopes_verif_mod, ONLY: iso_verif_trac17_q_deltad,iso_verif_traceur, &
    18551868&       iso_verif_traceur_justmass
    18561869#endif
    18571870#endif
    18581871#endif
    1859   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    1860           , clmci, eps, epsi, epsim1, ginv, hrd, grav
     1872USE cvthermo_mod_h
     1873
    18611874  IMPLICIT NONE
    18621875
    … …  
    18661879  ! - vectorisation de la partie normalisation des flux (do 789...)
    18671880  ! ---------------------------------------------------------------------
    1868 
    1869   include "cv30param.h"
    18701881
    18711882  ! inputs:
    … …  
    18821893  REAL m(nloc, na) ! input of convect3
    18831894#ifdef ISO
    1884       real xt(ntraciso,nloc,na), xtclw(ntraciso,nloc,na)
    1885       real tg_save(nloc,nd)
    1886       real xtnk(ntraciso,nloc)
     1895      REAL xt(ntraciso,nloc,na), xtclw(ntraciso,nloc,na)
     1896      REAL tg_save(nloc,nd)
     1897      REAL xtnk(ntraciso,nloc)
    18871898!      real xtep(ntraciso,nloc,na)
    18881899#endif
    … …  
    18961907  REAL sigij(nloc, nd, nd)
    18971908#ifdef ISO
    1898       real xtent(ntraciso,nloc,nd,nd)
    1899       real xtelij(ntraciso,nloc,nd,nd)     
     1909      REAL xtent(ntraciso,nloc,nd,nd)
     1910      REAL xtelij(ntraciso,nloc,nd,nd)
    19001911#endif
    19011912
    … …  
    19121923  LOGICAL lwork(nloc)
    19131924#ifdef ISO
    1914       integer ixt
    1915       real xtrti(ntraciso,nloc)
    1916       real xtres(ntraciso)
     1925      INTEGER ixt
     1926      REAL xtrti(ntraciso,nloc)
     1927      REAL xtres(ntraciso)
    19171928      ! on ajoute la dimension nloc a xtrti pour verifs dans les tags: 5 fev
    19181929      ! 2010
    1919       real zfice(nloc),zxtliq(ntraciso,nloc),zxtice(ntraciso,nloc)
     1930      REAL zfice(nloc),zxtliq(ntraciso,nloc),zxtice(ntraciso,nloc)
    19201931!      real xt_reduit(ntraciso)
    1921 !      logical negation
     1932!      LOGICAL negation
    19221933!#ifdef ISOVERIF
    19231934!       integer iso_verif_positif_nostop
    … …  
    19301941#ifdef ISO
    19311942#ifdef ISOVERIF
    1932       write(*,*) 'cv30_routines 1820: entree dans cv3_mixing'
    1933       if (iso_eau.gt.0) then
    1934       call iso_verif_egalite_vect2D( &
    1935      &           xtclw,clw, &
    1936      &           'cv30_mixing 1841',ntraciso,nloc,na)
     1943      WRITE(*,*) 'cv30_routines 1820: entree dans cv3_mixing'
     1944      IF (iso_eau.gt.0) THEN
     1945      CALL iso_verif_egalite_vect2D( &
     1946                 xtclw,clw, &
     1947                 'cv30_mixing 1841',ntraciso,nloc,na)
    19371948      endif
    19381949#endif
    … …  
    19651976
    19661977#ifdef ISO
    1967       do j=1,nd
    1968        do k=1,nd
    1969           do i=1,ncum
    1970             do ixt =1,ntraciso
     1978      DO j=1,nd
     1979       DO k=1,nd
     1980          DO i=1,ncum
     1981            DO ixt =1,ntraciso
    19711982             xtent(ixt,i,k,j)=xt(ixt,i,j)
    19721983             xtelij(ixt,i,k,j)=0.0
    … …  
    19751986            ! valeurs en nd=nl+1 ne sont pas utilisees
    19761987            qent(i,k,j)=rr(i,j)
    1977             elij(i,k,j)=0.0   
     1988            elij(i,k,j)=0.0
    19781989         enddo !do i=1,ncum
    19791990       enddo !do k=1,nl
    1980       enddo   !do j=1,nl 
     1991      enddo   !do j=1,nl
    19811992#endif
    19821993
    … …  
    20392050            ! !!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
    20402051            ! !!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
    2041             ! !!!      end do
     2052            ! !!!      END DO
    20422053            elij(il, i, j) = altem
    20432054            elij(il, i, j) = amax1(0.0, elij(il,i,j))
    … …  
    20532064#ifdef ISO
    20542065#ifdef ISOVERIF
    2055         !write(*,*) 'cv30_routines tmp 2078'
    2056 #endif
    2057        do il=1,ncum
     2066        !WRITE(*,*) 'cv30_routines tmp 2078'
     2067#endif
     2068       DO il=1,ncum
    20582069         zfice(il) = 1.0-(t(il,j)-pxtice)/(pxtmelt-pxtice)
    2059          zfice(il) = MIN(MAX(zfice(il),0.0),1.0)       
    2060          if( (i.ge.icb(il)).and.(i.le.inb(il)).and. &
    2061      &      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
    2062           do ixt=1,ntraciso
     2070         zfice(il) = MIN(MAX(zfice(il),0.0),1.0)
     2071         IF( (i.ge.icb(il)).AND.(i.le.inb(il)).AND. &
     2072            (j.ge.(icb(il)-1)).AND.(j.le.inb(il)))THEN
     2073          DO ixt=1,ntraciso
    20632074!           xtrti(ixt)=xt(ixt,il,1)-xtep(ixt,il,i)*xtclw(ixt,il,i) ! le 7 mai: on supprime xtep
    2064            xtrti(ixt,il)=xt(ixt,il,1)-ep(il,i)*xtclw(ixt,il,i)     
     2075           xtrti(ixt,il)=xt(ixt,il,1)-ep(il,i)*xtclw(ixt,il,i)
    20652076          enddo
    2066           if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then   
     2077          IF(sij(il,i,j).gt.0.0.AND.sij(il,i,j).lt.0.95)THEN
    20672078! temperature of condensation (within mixtures):
    2068 !          tcond(il)=t(il,j) 
    2069 !     :     + ( sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti 
     2079!          tcond(il)=t(il,j)
     2080!     :     + ( sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti
    20702081!     :             - elij(il,i,j) - rs(il,j) )
    20712082!     :        / ( cpd*(bf2-1.0)/lv(il,j) )
    2072                    
    2073           do ixt = 1, ntraciso
     2083
     2084          DO ixt = 1, ntraciso
    20742085! total mixing ratio in the mixtures before precipitation:
    20752086           xtent(ixt,il,i,j)=sij(il,i,j)*xt(ixt,il,i) &
    2076      &                       +(1.-sij(il,i,j))*xtrti(ixt,il)
     2087                             +(1.-sij(il,i,j))*xtrti(ixt,il)
    20772088          enddo !do ixt = 1, ntraciso
    2078          endif  !if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then 
    2079         endif !if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
    2080        enddo  !do il=1,ncum 
    2081 
    2082        call condiso_liq_ice_vectall(xtent(1,1,i,j),qent(1,i,j), &
    2083      &           elij(1,i,j), &
    2084      &           t(1,j),zfice(1),zxtice(1,1),zxtliq(1,1),ncum)
     2089         endif  !IF(sij(il,i,j).gt.0.0.AND.sij(il,i,j).lt.0.95)THEN
     2090        endif !IF( (i.ge.icb(il)).AND.(i.le.inb(il)).AND.
     2091       enddo  !do il=1,ncum
     2092
     2093       CALL condiso_liq_ice_vectall(xtent(1,1,i,j),qent(1,i,j), &
     2094                 elij(1,i,j), &
     2095                 t(1,j),zfice(1),zxtice(1,1),zxtliq(1,1),ncum)
    20852096#ifdef ISOTRAC
    2086         call condiso_liq_ice_vectall_trac(xtent(1,1,i,j),qent(1,i,j), &
    2087      &           elij(1,i,j), &
    2088      &           t(1,j),zfice(1),zxtice(1,1),zxtliq(1,1),ncum) 
    2089 #ifdef ISOVERIF
    2090         do il=1,ncum
    2091           call iso_verif_traceur(xt(1,il,i),'cv30_routines 1967')
    2092           if( (i.ge.icb(il)).and.(i.le.inb(il)).and. &
    2093      &      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
    2094           call iso_verif_traceur(xtrti(1,il),'cv30_routines 1968')
    2095           endif !if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
    2096           call iso_verif_traceur(xtent(1,il,i,j),'cv30_routines 1969')
    2097          
     2097        CALL condiso_liq_ice_vectall_trac(xtent(1,1,i,j),qent(1,i,j), &
     2098                 elij(1,i,j), &
     2099                 t(1,j),zfice(1),zxtice(1,1),zxtliq(1,1),ncum)
     2100#ifdef ISOVERIF
     2101        DO il=1,ncum
     2102          CALL iso_verif_traceur(xt(1,il,i),'cv30_routines 1967')
     2103          IF( (i.ge.icb(il)).AND.(i.le.inb(il)).AND. &
     2104            (j.ge.(icb(il)-1)).AND.(j.le.inb(il)))THEN
     2105          CALL iso_verif_traceur(xtrti(1,il),'cv30_routines 1968')
     2106          endif !IF( (i.ge.icb(il)).AND.(i.le.inb(il)).AND.
     2107          CALL iso_verif_traceur(xtent(1,il,i,j),'cv30_routines 1969')
     2108
    20982109        enddo !do il=1,ncum
    2099 #endif     
    2100 #endif     
    2101         do il=1,ncum
    2102          do ixt = 1, ntraciso
     2110#endif
     2111#endif
     2112        DO il=1,ncum
     2113         DO ixt = 1, ntraciso
    21032114          xtelij(ixt,il,i,j)=zxtice(ixt,il)+zxtliq(ixt,il)
    21042115         enddo !do ixt = 1, ntraciso
    … …  
    21062117
    21072118#ifdef ISOVERIF
    2108         if ((j.eq.15).and.(i.eq.15)) then
     2119        IF ((j.EQ.15).AND.(i.EQ.15)) THEN
    21092120        il=2722
    2110         if (il.le.ncum) then
    2111                 write(*,*) 'cv30_routines tmp 2194, il,i,j=',il,i,j
    2112                 write(*,*) 'qent,elij=',qent(il,i,j),elij(il,i,j)
    2113                 write(*,*) 'tgsave,zfice=',t(il,j),zfice(il)
    2114                 write(*,*) 'deltaDqent=',deltaD(xtent(iso_HDO,il,i,j)/qent(il,i,j))
    2115                 write(*,*) 'deltaDelij=',deltaD(xtelij(iso_HDO,il,i,j)/elij(il,i,j))
    2116                 write(*,*) 'deltaDice=',deltaD(zxtice(iso_HDO,il)/(zfice(il)*elij(il,i,j)))
    2117                 write(*,*) 'deltaDliq=',deltaD(zxtliq(iso_HDO,il)/(1.0-zfice(il)*elij(il,i,j)))
     2121        IF (il.le.ncum) THEN
     2122                WRITE(*,*) 'cv30_routines tmp 2194, il,i,j=',il,i,j
     2123                WRITE(*,*) 'qent,elij=',qent(il,i,j),elij(il,i,j)
     2124                WRITE(*,*) 'tgsave,zfice=',t(il,j),zfice(il)
     2125                WRITE(*,*) 'deltaDqent=',deltaD(xtent(iso_HDO,il,i,j)/qent(il,i,j))
     2126                WRITE(*,*) 'deltaDelij=',deltaD(xtelij(iso_HDO,il,i,j)/elij(il,i,j))
     2127                WRITE(*,*) 'deltaDice=',deltaD(zxtice(iso_HDO,il)/(zfice(il)*elij(il,i,j)))
     2128                WRITE(*,*) 'deltaDliq=',deltaD(zxtliq(iso_HDO,il)/(1.0-zfice(il)*elij(il,i,j)))
    21182129        endif
    21192130        endif
    21202131#endif
    21212132
    2122 #ifdef ISOTRAC   
    2123 !        write(*,*) 'cv30_routines tmp 1987,option_traceurs=',
     2133#ifdef ISOTRAC
     2134!        WRITE(*,*) 'cv30_routines tmp 1987,option_traceurs=',
    21242135!     :           option_traceurs
    2125         if (option_tmin.ge.1) then
    2126         do il=1,ncum   
    2127 !        write(*,*) 'cv3 tmp 1991 il,i,j,xtent(:,il,i,j),',
     2136        IF (option_tmin.ge.1) THEN
     2137        DO il=1,ncum
     2138!        WRITE(*,*) 'cv3 tmp 1991 il,i,j,xtent(:,il,i,j),',
    21282139!     :           'tcond(il),rs(il,j)=',
    21292140!     :            il,i,j,xtent(:,il,i,j),tcond(il),rs(il,j)
    21302141        ! colorier la vapeur residuelle selon temperature de
    21312142        ! condensation, et le condensat en un tag spEcifique
    2132           if ((elij(il,i,j).gt.0.0).and.(qent(il,i,j).gt.0.0)) then 
    2133             if (option_traceurs.eq.17) then       
    2134              call iso_recolorise_condensation(qent(il,i,j),elij(il,i,j), &
    2135      &           xtent(1,il,i,j),xtelij(1,il,i,j),t(1,j), &
    2136      &           0.0,xtres, &
    2137      &           seuil_tag_tmin)
    2138             else !if (option_traceurs.eq.17) then
    2139 !             write(*,*) 'cv3 2002: il,i,j  =',il,i,j   
    2140              call iso_recolorise_condensation(qent(il,i,j),elij(il,i,j), &
    2141      &           xtent(1,il,i,j),xtelij(1,il,i,j),rs(il,j),0.0,xtres, &
    2142      &           seuil_tag_tmin)
    2143             endif !if (option_traceurs.eq.17) then
    2144             do ixt=1+niso,ntraciso
     2143          IF ((elij(il,i,j).gt.0.0).AND.(qent(il,i,j).gt.0.0)) THEN
     2144            IF (option_traceurs.EQ.17) THEN
     2145             CALL iso_recolorise_condensation(qent(il,i,j),elij(il,i,j), &
     2146                 xtent(1,il,i,j),xtelij(1,il,i,j),t(1,j), &
     2147                 0.0,xtres, &
     2148                 seuil_tag_tmin)
     2149            else !if (option_traceurs.EQ.17) THEN
     2150!             WRITE(*,*) 'cv3 2002: il,i,j  =',il,i,j
     2151             CALL iso_recolorise_condensation(qent(il,i,j),elij(il,i,j), &
     2152                 xtent(1,il,i,j),xtelij(1,il,i,j),rs(il,j),0.0,xtres, &
     2153                 seuil_tag_tmin)
     2154            endif !if (option_traceurs.EQ.17) THEN
     2155            DO ixt=1+niso,ntraciso
    21452156               xtent(ixt,il,i,j)=xtres(ixt)
    2146             enddo     
    2147           endif !if (cond.gt.0.0) then
     2157            enddo
     2158          endif !if (cond.gt.0.0) THEN
    21482159        enddo !do il=1,ncum
    21492160#ifdef ISOVERIF
    2150         do il=1,ncum
    2151           call iso_verif_traceur(xtent(1,il,i,j),'cv30_routines 1996')
    2152           call iso_verif_traceur(xtelij(1,il,i,j),'cv30_routines 1997')
    2153           call iso_verif_trac17_q_deltaD(xtent(1,il,i,j), &
    2154      &           'cv30_routines 2042')
    2155         enddo !do il=1,ncum 
    2156 #endif       
    2157         endif !if (option_tmin.ge.1) then       
     2161        DO il=1,ncum
     2162          CALL iso_verif_traceur(xtent(1,il,i,j),'cv30_routines 1996')
     2163          CALL iso_verif_traceur(xtelij(1,il,i,j),'cv30_routines 1997')
     2164          CALL iso_verif_trac17_q_deltaD(xtent(1,il,i,j), &
     2165                 'cv30_routines 2042')
     2166        enddo !do il=1,ncum
     2167#endif
     2168        endif !if (option_tmin.ge.1) THEN
    21582169#endif
    21592170
    21602171! fractionation:
    2161 #ifdef ISOVERIF 
    2162 !        write(*,*) 'cv30_routines 2050: avant condiso'
    2163         do il=1,ncum
    2164         if ((i.ge.icb(il)).and.(i.le.inb(il)).and. &
    2165      &      (j.ge.(icb(il)-1)).and.(j.le.inb(il))) then
    2166         if (sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95) then 
    2167         if (iso_eau.gt.0) then
    2168           call iso_verif_egalite_choix(xtent(iso_eau,il,i,j), &
    2169      &        qent(il,i,j),'cv30_routines 1889',errmax,errmaxrel)   
    2170           call iso_verif_egalite_choix(xtelij(iso_eau,il,i,j), &
    2171      &        elij(il,i,j),'cv30_routines 1890',errmax,errmaxrel)
     2172#ifdef ISOVERIF
     2173!        WRITE(*,*) 'cv30_routines 2050: avant condiso'
     2174        DO il=1,ncum
     2175        IF ((i.ge.icb(il)).AND.(i.le.inb(il)).AND. &
     2176            (j.ge.(icb(il)-1)).AND.(j.le.inb(il))) THEN
     2177        IF (sij(il,i,j).gt.0.0.AND.sij(il,i,j).lt.0.95) THEN
     2178        IF (iso_eau.gt.0) THEN
     2179          CALL iso_verif_egalite_choix(xtent(iso_eau,il,i,j), &
     2180              qent(il,i,j),'cv30_routines 1889',errmax,errmaxrel)
     2181          CALL iso_verif_egalite_choix(xtelij(iso_eau,il,i,j), &
     2182              elij(il,i,j),'cv30_routines 1890',errmax,errmaxrel)
    21722183        endif
    2173         if (iso_HDO.gt.0) then   
    2174           call iso_verif_aberrant_choix(xt(iso_HDO,il,i),rr(il,i), &
    2175      &            ridicule,deltalim,'cv30_routines 1997')         
    2176           call iso_verif_aberrant_choix( &
    2177      &            xtent(iso_HDO,il,i,j),qent(il,i,j), &
    2178      &            ridicule,deltalim,'cv30_routines 1931')
    2179           call iso_verif_aberrant_choix( &
    2180      &            xtelij(iso_HDO,il,i,j),elij(il,i,j), &
    2181      &            ridicule,deltalim,'cv30_routines 1993')
    2182         endif !if (iso_HDO.gt.0) then
    2183 #ifdef ISOTRAC 
    2184 !        write(*,*) 'cv30_routines tmp 2039 il=',il
    2185            call iso_verif_traceur(xtent(1,il,i,j), &
    2186      &                   'cv30_routines 2031')
    2187            call iso_verif_traceur(xtelij(1,il,i,j), &
    2188      &                   'cv30_routines 2033')
    2189 #endif       
    2190 
    2191         endif !if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then 
    2192         endif !if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
     2184        IF (iso_HDO.gt.0) THEN
     2185          CALL iso_verif_aberrant_choix(xt(iso_HDO,il,i),rr(il,i), &
     2186                  ridicule,deltalim,'cv30_routines 1997')
     2187          CALL iso_verif_aberrant_choix( &
     2188                  xtent(iso_HDO,il,i,j),qent(il,i,j), &
     2189                  ridicule,deltalim,'cv30_routines 1931')
     2190          CALL iso_verif_aberrant_choix( &
     2191                  xtelij(iso_HDO,il,i,j),elij(il,i,j), &
     2192                  ridicule,deltalim,'cv30_routines 1993')
     2193        endif !if (iso_HDO.gt.0) THEN
     2194#ifdef ISOTRAC
     2195!        WRITE(*,*) 'cv30_routines tmp 2039 il=',il
     2196           CALL iso_verif_traceur(xtent(1,il,i,j), &
     2197                         'cv30_routines 2031')
     2198           CALL iso_verif_traceur(xtelij(1,il,i,j), &
     2199                         'cv30_routines 2033')
     2200#endif
     2201
     2202        endif !IF(sij(il,i,j).gt.0.0.AND.sij(il,i,j).lt.0.95)THEN
     2203        endif !IF( (i.ge.icb(il)).AND.(i.le.inb(il)).AND.
    21932204        enddo !do il=1,ncum
    21942205#endif
    2195 !        write(*,*) 'cv30_routine tmp 1984: cond=',elij(il,i,j)
    2196          
    2197        
     2206!        WRITE(*,*) 'cv30_routine tmp 1984: cond=',elij(il,i,j)
     2207
     2208
    21982209#endif
    21992210
    … …  
    22032214    ! do j=minorig,nl
    22042215    ! do il=1,ncum
    2205     ! if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
    2206     ! :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
     2216    ! IF( (i.ge.icb(il)).AND.(i.le.inb(il)).AND.
     2217    ! :       (j.ge.(icb(il)-1)).AND.(j.le.inb(il)))THEN
    22072218    ! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
    22082219    ! :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
    2209     ! endif
     2220    ! END IF
    22102221    ! enddo
    22112222    ! enddo
    … …  
    22232234    DO il = 1, ncum
    22242235      IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN
    2225         ! @      if(nent(il,i).eq.0)then
     2236        ! @      IF(nent(il,i).EQ.0)THEN
    22262237        ment(il, i, i) = m(il, i)
    22272238        qent(il, i, i) = rr(il, nk(il)) - ep(il, i)*clw(il, i)
    … …  
    22322243        sij(il, i, i) = 0.0
    22332244#ifdef ISO
    2234       do ixt = 1, ntraciso
     2245      DO ixt = 1, ntraciso
    22352246       xtent(ixt,il,i,i)=xt(ixt,il,nk(il))-ep(il,i)*xtclw(ixt,il,i)
    2236 !      xtent(ixt,il,i,i)=xt(ixt,il,nk(il))-xtep(ixt,il,i)*xtclw(ixt,il,i) 
     2247!      xtent(ixt,il,i,i)=xt(ixt,il,nk(il))-xtep(ixt,il,i)*xtclw(ixt,il,i)
    22372248        ! le 7 mai: on supprime xtep
    22382249        xtelij(ixt,il,i,i)=xtclw(ixt,il,i) ! rq: ne sera pas utilise ensuite
    … …  
    22402251
    22412252#ifdef ISOVERIF
    2242        if (iso_eau.gt.0) then
    2243          call iso_verif_egalite_choix(xtelij(iso_eau,il,i,i), &
    2244      &         elij(il,i,i),'cv30_mixing 2117',errmax,errmaxrel)
    2245        endif !if (iso_eau.gt.0) then
    2246 #endif
    2247 
    2248 #ifdef ISOTRAC         
    2249         if (option_tmin.ge.1) then
     2253       IF (iso_eau.gt.0) THEN
     2254         CALL iso_verif_egalite_choix(xtelij(iso_eau,il,i,i), &
     2255               elij(il,i,i),'cv30_mixing 2117',errmax,errmaxrel)
     2256       endif !if (iso_eau.gt.0) THEN
     2257#endif
     2258
     2259#ifdef ISOTRAC
     2260        IF (option_tmin.ge.1) THEN
    22502261        ! colorier la vapeur residuelle selon temperature de
    22512262        ! condensation, et le condensat en un tag specifique
    2252 !        write(*,*) 'cv3 tmp 2095 il,i,j,xtent(:,il,i,j)=',
     2263!        WRITE(*,*) 'cv3 tmp 2095 il,i,j,xtent(:,il,i,j)=',
    22532264!     :            il,i,j,xtent(:,il,i,j)
    2254           if ((elij(il,i,i).gt.0.0).and.(qent(il,i,i).gt.0.0)) then
    2255             if (option_traceurs.eq.17) then
    2256              call iso_recolorise_condensation(qent(il,i,i), &
    2257      &           elij(il,i,i), &
    2258      &           xt(1,il,nk(il)),xtclw(1,il,i),t(il,i),ep(il,i), &
    2259      &           xtres, &
    2260      &           seuil_tag_tmin)
    2261             else !if (option_traceurs.eq.17) then
    2262              call iso_recolorise_condensation(qent(il,i,i), &
    2263      &           elij(il,i,i), &
    2264      &           xt(1,il,nk(il)),xtclw(1,il,i),rs(il,i),ep(il,i), &
    2265      &           xtres, &
    2266      &           seuil_tag_tmin)
    2267             endif !if (option_traceurs.eq.17) then
    2268             do ixt=1+niso,ntraciso
     2265          IF ((elij(il,i,i).gt.0.0).AND.(qent(il,i,i).gt.0.0)) THEN
     2266            IF (option_traceurs.EQ.17) THEN
     2267             CALL iso_recolorise_condensation(qent(il,i,i), &
     2268                 elij(il,i,i), &
     2269                 xt(1,il,nk(il)),xtclw(1,il,i),t(il,i),ep(il,i), &
     2270                 xtres, &
     2271                 seuil_tag_tmin)
     2272            else !if (option_traceurs.EQ.17) THEN
     2273             CALL iso_recolorise_condensation(qent(il,i,i), &
     2274                 elij(il,i,i), &
     2275                 xt(1,il,nk(il)),xtclw(1,il,i),rs(il,i),ep(il,i), &
     2276                 xtres, &
     2277                 seuil_tag_tmin)
     2278            endif !if (option_traceurs.EQ.17) THEN
     2279            DO ixt=1+niso,ntraciso
    22692280              xtent(ixt,il,i,i)=xtres(ixt)
    22702281            enddo
    2271 #ifdef ISOVERIF           
    2272             do ixt=1,niso
    2273             call iso_verif_egalite_choix(xtres(ixt),xtent(ixt,il,i,i), &
    2274      &           'cv30_routines 2102',errmax,errmaxrel)
    2275             call iso_verif_trac17_q_deltaD(xtent(1,il,i,j), &
    2276      &           'cv30_routines 2154')
     2282#ifdef ISOVERIF
     2283            DO ixt=1,niso
     2284            CALL iso_verif_egalite_choix(xtres(ixt),xtent(ixt,il,i,i), &
     2285                 'cv30_routines 2102',errmax,errmaxrel)
     2286            CALL iso_verif_trac17_q_deltaD(xtent(1,il,i,j), &
     2287                 'cv30_routines 2154')
    22772288            enddo
    2278 #endif           
    2279           endif !if (cond.gt.0.0) then
    2280          
    2281 #ifdef ISOVERIF         
    2282           call iso_verif_egalite_choix(xtent(iso_eau,il,i,i), &
    2283      &           qent(il,i,i),'cv30_routines 2103',errmax,errmaxrel)
    2284           call iso_verif_traceur(xtent(1,il,i,i),'cv30_routines 2095')
    2285           call iso_verif_traceur(xtelij(1,il,i,i),'cv30_routines 2096')
    2286 #endif       
    2287         endif !if (option_tmin.ge.1) then   
     2289#endif
     2290          endif !if (cond.gt.0.0) THEN
     2291#ifdef ISOVERIF
     2292          CALL iso_verif_egalite_choix(xtent(iso_eau,il,i,i), &
     2293                 qent(il,i,i),'cv30_routines 2103',errmax,errmaxrel)
     2294          CALL iso_verif_traceur(xtent(1,il,i,i),'cv30_routines 2095')
     2295          CALL iso_verif_traceur(xtelij(1,il,i,i),'cv30_routines 2096')
     2296#endif
     2297        endif !if (option_tmin.ge.1) THEN
    22882298#endif
    22892299
    … …  
    22962306  ! do i=minorig+1,nl
    22972307  ! do il=1,ncum
    2298   ! if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
     2308  ! if (i.ge.icb(il) .AND. i.le.inb(il) .AND. nent(il,i).EQ.0) THEN
    22992309  ! traent(il,i,i,j)=tra(il,nk(il),j)
    2300   ! endif
     2310  ! END IF
    23012311  ! enddo
    23022312  ! enddo
    … …  
    23222332  ! =====================================================================
    23232333
    2324   ! ym      call zilch(asum,ncum*nd)
    2325   ! ym      call zilch(bsum,ncum*nd)
    2326   ! ym      call zilch(csum,ncum*nd)
     2334  ! ym      CALL zilch(asum,ncum*nd)
     2335  ! ym      CALL zilch(bsum,ncum*nd)
     2336  ! ym      CALL zilch(csum,ncum*nd)
    23272337  CALL zilch(asum, nloc*nd)
    23282338  CALL zilch(csum, nloc*nd)
    … …  
    24662476        sij(il, i, i) = 0.0
    24672477#ifdef ISO
    2468       do ixt = 1, ntraciso
     2478      DO ixt = 1, ntraciso
    24692479!      xtent(ixt,il,i,i)=xt(ixt,il,1)-xtep(ixt,il,i)*xtclw(ixt,il,i)
    24702480        xtent(ixt,il,i,i)=xt(ixt,il,1)-ep(il,i)*xtclw(ixt,il,i)
    … …  
    24742484
    24752485#ifdef ISOVERIF
    2476       if (iso_eau.gt.0) then
    2477         call iso_verif_egalite_choix(xtelij(iso_eau,il,i,i), &
    2478      &         elij(il,i,i),'cv30_mixing 2354',errmax,errmaxrel)
    2479       endif  !if (iso_eau.gt.0) then
    2480 #endif
    2481 
    2482 #ifdef ISOTRAC         
    2483         if (option_tmin.ge.1) then
     2486      IF (iso_eau.gt.0) THEN
     2487        CALL iso_verif_egalite_choix(xtelij(iso_eau,il,i,i), &
     2488               elij(il,i,i),'cv30_mixing 2354',errmax,errmaxrel)
     2489      endif  !if (iso_eau.gt.0) THEN
     2490#endif
     2491
     2492#ifdef ISOTRAC
     2493        IF (option_tmin.ge.1) THEN
    24842494        ! colorier la vapeur residuelle selon temperature de
    24852495        ! condensation, et le condensat en un tag specifique
    2486 !        write(*,*) 'cv3 tmp 2314 il,i,j,xtent(:,il,i,j)=',
     2496!        WRITE(*,*) 'cv3 tmp 2314 il,i,j,xtent(:,il,i,j)=',
    24872497!     :            il,i,j,xtent(:,il,i,j)
    2488           if ((elij(il,i,i).gt.0.0).and.(qent(il,i,i).gt.0.0)) then
    2489             if (option_traceurs.eq.17) then         
    2490               call iso_recolorise_condensation(qent(il,i,i), &
    2491      &           elij(il,i,i), &
    2492      &           xt(1,il,1),xtclw(1,il,i),t(il,i),ep(il,i), &
    2493      &           xtres, &
    2494      &           seuil_tag_tmin)
    2495             else !if (option_traceurs.eq.17) then
    2496               call iso_recolorise_condensation(qent(il,i,i), &
    2497      &           elij(il,i,i), &
    2498      &           xt(1,il,1),xtclw(1,il,i),rs(il,i),ep(il,i), &
    2499      &           xtres, &
    2500      &           seuil_tag_tmin)
    2501             endif ! if (option_traceurs.eq.17) then
    2502             do ixt=1+niso,ntraciso
     2498          IF ((elij(il,i,i).gt.0.0).AND.(qent(il,i,i).gt.0.0)) THEN
     2499            IF (option_traceurs.EQ.17) THEN
     2500              CALL iso_recolorise_condensation(qent(il,i,i), &
     2501                 elij(il,i,i), &
     2502                 xt(1,il,1),xtclw(1,il,i),t(il,i),ep(il,i), &
     2503                 xtres, &
     2504                 seuil_tag_tmin)
     2505            else !if (option_traceurs.EQ.17) THEN
     2506              CALL iso_recolorise_condensation(qent(il,i,i), &
     2507                 elij(il,i,i), &
     2508                 xt(1,il,1),xtclw(1,il,i),rs(il,i),ep(il,i), &
     2509                 xtres, &
     2510                 seuil_tag_tmin)
     2511            endif ! if (option_traceurs.EQ.17) THEN
     2512            DO ixt=1+niso,ntraciso
    25032513              xtent(ixt,il,i,i)=xtres(ixt)
    2504             enddo 
    2505 #ifdef ISOVERIF               
    2506             do ixt=1,niso
    2507               call iso_verif_egalite_choix(xtres(ixt),xtent(ixt,il,i,i), &
    2508      &           'cv30_routines 2318',errmax,errmaxrel)
    2509               call iso_verif_trac17_q_deltaD(xtent(1,il,i,j), &
    2510      &           'cv30_routines 2383')
    25112514            enddo
    2512 #endif               
    2513           endif !if (cond.gt.0.0) then
    2514 #ifdef ISOVERIF         
    2515           call iso_verif_egalite_choix(xtent(iso_eau,il,i,i), &
    2516      &           qent(il,i,i),'cv30_routines 2321',errmax,errmaxrel)
    2517           call iso_verif_traceur(xtent(1,il,i,i),'cv30_routines 2322')
    2518           call iso_verif_traceur(xtelij(1,il,i,i),'cv30_routines 2323')
    2519 #endif       
    2520         endif !if (option_tmin.ge.1) then
     2515#ifdef ISOVERIF
     2516            DO ixt=1,niso
     2517              CALL iso_verif_egalite_choix(xtres(ixt),xtent(ixt,il,i,i), &
     2518                 'cv30_routines 2318',errmax,errmaxrel)
     2519              CALL iso_verif_trac17_q_deltaD(xtent(1,il,i,j), &
     2520                 'cv30_routines 2383')
     2521            enddo
     2522#endif
     2523          endif !if (cond.gt.0.0) THEN
     2524#ifdef ISOVERIF
     2525          CALL iso_verif_egalite_choix(xtent(iso_eau,il,i,i), &
     2526                 qent(il,i,i),'cv30_routines 2321',errmax,errmaxrel)
     2527          CALL iso_verif_traceur(xtent(1,il,i,i),'cv30_routines 2322')
     2528          CALL iso_verif_traceur(xtelij(1,il,i,i),'cv30_routines 2323')
     2529#endif
     2530        endif !if (option_tmin.ge.1) THEN
    25212531#endif
    25222532      END IF
    … …  
    25252535    ! do j=1,ntra
    25262536    ! do il=1,ncum
    2527     ! if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
    2528     ! :     .and. csum(il,i).lt.m(il,i) ) then
     2537    ! if ( i.ge.icb(il) .AND. i.le.inb(il) .AND. lwork(il)
     2538    ! :     .AND. csum(il,i).lt.m(il,i) ) THEN
    25292539    ! traent(il,i,i,j)=tra(il,nk(il),j)
    2530     ! endif
     2540    ! END IF
    25312541    ! enddo
    25322542    ! enddo
    … …  
    25652575!c--debug
    25662576#ifdef ISOVERIF
    2567        do im = 1, nd
    2568        do jm = 1, nd
    2569         do il = 1, ncum
    2570           if (iso_eau.gt.0) then
    2571             call iso_verif_egalite_choix(xtelij(iso_eau,il,im,jm), &
    2572      &         elij(il,im,jm),'cv30_mixing 2110',errmax,errmaxrel)
    2573             call iso_verif_egalite_choix(xtent(iso_eau,il,im,jm),  &                 
    2574      &         qent(il,im,jm),'cv30_mixing 2112',errmax,errmaxrel)
    2575           endif !if (iso_eau.gt.0) then
     2577       DO im = 1, nd
     2578       DO jm = 1, nd
     2579        DO il = 1, ncum
     2580          IF (iso_eau.gt.0) THEN
     2581            CALL iso_verif_egalite_choix(xtelij(iso_eau,il,im,jm), &
     2582               elij(il,im,jm),'cv30_mixing 2110',errmax,errmaxrel)
     2583            CALL iso_verif_egalite_choix(xtent(iso_eau,il,im,jm),  &
     2584               qent(il,im,jm),'cv30_mixing 2112',errmax,errmaxrel)
     2585          endif !if (iso_eau.gt.0) THEN
    25762586#ifdef ISOTRAC
    2577         call iso_verif_traceur_justmass(xtelij(1,il,im,jm), &     
    2578      &                  'cv30_routine 2250')
    2579 #endif           
     2587        CALL iso_verif_traceur_justmass(xtelij(1,il,im,jm), &
     2588                        'cv30_routine 2250')
     2589#endif
    25802590        enddo !do il = 1, nloc
    25812591       enddo !do jm = 1, klev
    25822592       enddo !do im = 1, klev
    25832593#endif
    2584 #endif 
     2594#endif
    25852595
    25862596#ifdef ISO
    25872597#ifdef ISOTRAC
    25882598        ! seulement a la fin on taggue le condensat
    2589         if (option_cond.ge.1) then
    2590          do im = 1, nd
    2591          do jm = 1, nd
    2592          do il = 1, ncum   
     2599        IF (option_cond.ge.1) THEN
     2600         DO im = 1, nd
     2601         DO jm = 1, nd
     2602         DO il = 1, ncum
    25932603           ! colorier le condensat en un tag specifique
    2594            do ixt=niso+1,ntraciso
    2595              if (index_zone(ixt).eq.izone_cond) then
     2604           DO ixt=niso+1,ntraciso
     2605             IF (index_zone(ixt).EQ.izone_cond) THEN
    25962606                xtelij(ixt,il,im,jm)=xtelij(index_iso(ixt),il,im,jm)
    2597              else !if (index_zone(ixt).eq.izone_cond) then
     2607             else !if (index_zone(ixt).EQ.izone_cond) THEN
    25982608                xtelij(ixt,il,im,jm)=0.0
    2599              endif !if (index_zone(ixt).eq.izone_cond) then
    2600            enddo !do ixt=1,ntraciso     
    2601 #ifdef ISOVERIF
    2602         call iso_verif_egalite_choix(xtelij(iso_eau,il,im,jm), &
    2603      &           elij(il,im,jm),'cv30_routines 2408',errmax,errmaxrel)
    2604         call iso_verif_traceur(xtelij(1,il,im,jm), &
    2605      &          'condiso_liq_ice_vectiso_trac 358')
    2606 #endif     
    2607          enddo !do il = 1, ncum   
     2609             endif !if (index_zone(ixt).EQ.izone_cond) THEN
     2610           enddo !do ixt=1,ntraciso
     2611#ifdef ISOVERIF
     2612        CALL iso_verif_egalite_choix(xtelij(iso_eau,il,im,jm), &
     2613                 elij(il,im,jm),'cv30_routines 2408',errmax,errmaxrel)
     2614        CALL iso_verif_traceur(xtelij(1,il,im,jm), &
     2615                'condiso_liq_ice_vectiso_trac 358')
     2616#endif
     2617         enddo !do il = 1, ncum
    26082618         enddo !do jm = 1, nd
    26092619         enddo !do im = 1, nd
    2610          do im = 1, nd
    2611          do il = 1, ncum   
     2620         DO im = 1, nd
     2621         DO il = 1, ncum
    26122622           ! colorier le condensat en un tag specifique
    2613            do ixt=niso+1,ntraciso
    2614              if (index_zone(ixt).eq.izone_cond) then
     2623           DO ixt=niso+1,ntraciso
     2624             IF (index_zone(ixt).EQ.izone_cond) THEN
    26152625                xtclw(ixt,il,im)=xtclw(index_iso(ixt),il,im)
    2616              else !if (index_zone(ixt).eq.izone_cond) then
     2626             else !if (index_zone(ixt).EQ.izone_cond) THEN
    26172627                xtclw(ixt,il,im)=0.0
    2618              endif !if (index_zone(ixt).eq.izone_cond) then
    2619            enddo !do ixt=1,ntraciso     
    2620 #ifdef ISOVERIF
    2621         call iso_verif_egalite_choix(xtclw(iso_eau,il,im), &
    2622      &           clw(il,im),'cv30_routines 2427',errmax,errmaxrel)
    2623         call iso_verif_traceur(xtclw(1,il,im), &
    2624      &          'condiso_liq_ice_vectiso_trac 358')
    2625         if (iso_verif_positif_nostop(xtclw(itZonIso( &
    2626      &           izone_cond,iso_eau),i,k)-xtclw(iso_eau,i,k) &
    2627      &           ,'cv30_routines 909').eq.1) then
    2628                write(*,*) 'i,k=',i,k
    2629                write(*,*) 'xtclw=',xtclw(:,i,k)
    2630                write(*,*) 'niso,ntraciso,index_zone,izone_cond=', &
    2631      &             niso,ntraciso,index_zone,izone_cond       
     2628             endif !if (index_zone(ixt).EQ.izone_cond) THEN
     2629           enddo !do ixt=1,ntraciso
     2630#ifdef ISOVERIF
     2631        CALL iso_verif_egalite_choix(xtclw(iso_eau,il,im), &
     2632                 clw(il,im),'cv30_routines 2427',errmax,errmaxrel)
     2633        CALL iso_verif_traceur(xtclw(1,il,im), &
     2634                'condiso_liq_ice_vectiso_trac 358')
     2635        IF (iso_verif_positif_nostop(xtclw(itZonIso( &
     2636                 izone_cond,iso_eau),i,k)-xtclw(iso_eau,i,k) &
     2637                 ,'cv30_routines 909').EQ.1) THEN
     2638               WRITE(*,*) 'i,k=',i,k
     2639               WRITE(*,*) 'xtclw=',xtclw(:,i,k)
     2640               WRITE(*,*) 'niso,ntraciso,index_zone,izone_cond=', &
     2641                   niso,ntraciso,index_zone,izone_cond
    26322642               stop
    26332643         endif !if (iso_verif_positif_nostop(xtclw(itZonIso(
    2634 #endif             
    2635          enddo !do il = 1, ncum   
     2644#endif
     2645         enddo !do il = 1, ncum
    26362646         enddo !do im = 1, nd
    2637 !         write(*,*) 'xtclw(:,1,2)=',xtclw(:,1,2)
    2638         endif !if (option_tmin.eq.1) then
    2639 #endif
    2640 #endif
    2641 
    2642   RETURN
     2647!         WRITE(*,*) 'xtclw(:,1,2)=',xtclw(:,1,2)
     2648        endif !if (option_tmin.EQ.1) THEN
     2649#endif
     2650#endif
     2651
     2652
    26432653END SUBROUTINE cv30_mixing
    26442654
    … …  
    26492659    , wdtraina, wdtrainm & ! 26/08/10  RomP-jyg
    26502660#ifdef ISO
    2651      &              ,xt,xtclw,xtelij &
    2652      &              ,xtp,xtwater,xtevap,xtwdtraina &
    2653 #endif
    2654      &          )
    2655 #ifdef ISO
    2656     use infotrac_phy, ONLY: ntraciso=>ntiso, niso
    2657     use isotopes_mod, ONLY: essai_convergence, iso_eau,iso_HDO,ridicule
    2658     use isotopes_routines_mod, ONLY: appel_stewart_vectall,appel_stewart_debug
    2659 #ifdef ISOVERIF
    2660     use isotopes_verif_mod, ONLY: errmax,errmaxrel, &
     2661                    ,xt,xtclw,xtelij &
     2662                    ,xtp,xtwater,xtevap,xtwdtraina &
     2663#endif
     2664                )
     2665#ifdef ISO
     2666    USE infotrac_phy, ONLY: ntraciso=>ntiso, niso
     2667    USE isotopes_mod, ONLY: essai_convergence, iso_eau,iso_HDO,ridicule
     2668    USE isotopes_routines_mod, ONLY: appel_stewart_vectall,appel_stewart_debug
     2669#ifdef ISOVERIF
     2670    USE isotopes_verif_mod, ONLY: errmax,errmaxrel, &
    26612671        iso_verif_egalite_choix, iso_verif_noNaN,iso_verif_aberrant, &
    26622672        iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
    … …  
    26652675#endif
    26662676#ifdef ISOTRAC
    2667     use isotrac_mod, only: option_cond,izone_cond
    2668     use infotrac_phy, ONLY: itZonIso
    2669 #ifdef ISOVERIF
    2670     use isotopes_verif_mod, ONLY: iso_verif_traceur_justmass, &
     2677    USE isotrac_mod, ONLY: option_cond,izone_cond
     2678    USE infotrac_phy, ONLY: itZonIso
     2679#ifdef ISOVERIF
     2680    USE isotopes_verif_mod, ONLY: iso_verif_traceur_justmass, &
    26712681&       iso_verif_traceur
    2672     use isotrac_routines_mod, ONLY: iso_verif_traceur_pbidouille
    2673 #endif
    2674 #endif
    2675 #endif
    2676 
    2677   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    2678           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    2679   USE cvflag_mod_h, ONLY: icvflag_Tpa, cvflag_grav, cvflag_ice, ok_optim_yield, ok_entrain, ok_homo_tend, &
    2680           ok_convstop, ok_intermittent, cvflag_prec_eject, qsat_depends_on_qt, adiab_ascent_mass_flux_depends_on_ejectliq, keepbug_ice_frac
     2682    USE isotrac_routines_mod, ONLY: iso_verif_traceur_pbidouille
     2683#endif
     2684#endif
     2685#endif
     2686USE cvflag_mod_h
     2687USE cvthermo_mod_h
     2688
    26812689  IMPLICIT NONE
    2682 
    2683 
    2684   include "cv30param.h"
    26852690
    26862691  ! inputs:
    … …  
    26972702  REAL m(nloc, na), ment(nloc, na, na), elij(nloc, na, na)
    26982703#ifdef ISO
    2699       real xt(ntraciso,nloc,nd), xtclw(ntraciso,nloc,na)
    2700       real xtelij(ntraciso,nloc,na,na)
     2704      REAL xt(ntraciso,nloc,nd), xtclw(ntraciso,nloc,na)
     2705      REAL xtelij(ntraciso,nloc,na,na)
    27012706!      real xtep(ntraciso,nloc,na) ! le 7 mai: on supprime xtep
    27022707#endif
    … …  
    27142719
    27152720#ifdef ISO
    2716       real xtp(ntraciso,nloc,na)
    2717       real xtwater(ntraciso,nloc,na), xtevap(ntraciso,nloc,na)
    2718       real xtwdtraina(ntraciso,nloc,na)
     2721      REAL xtp(ntraciso,nloc,na)
     2722      REAL xtwater(ntraciso,nloc,na), xtevap(ntraciso,nloc,na)
     2723      REAL xtwdtraina(ntraciso,nloc,na)
    27192724#endif
    27202725
    … …  
    27312736
    27322737#ifdef ISO
    2733       integer ixt
    2734       real xtawat(ntraciso)
     2738      INTEGER ixt
     2739      REAL xtawat(ntraciso)
    27352740  REAL xtwdtrain(ntraciso,nloc)
    2736 !      logical negation
    2737       real rpprec(nloc,na)
     2741!      LOGICAL negation
     2742      REAL rpprec(nloc,na)
    27382743!#ifdef ISOVERIF
    27392744!      integer iso_verif_aberrant_nostop
    2740 !#ifdef ISOTRAC     
     2745!#ifdef ISOTRAC
    27412746!      integer iso_verif_traceur_choix_nostop
    27422747!      integer iso_verif_positif_nostop
    2743 !#endif     
    2744 !#endif 
     2748!#endif
     2749!#endif
    27452750#endif
    27462751
    … …  
    27482753  ! ------------------------------------------------------
    27492754!#ifdef ISOVERIF
    2750 !        write(*,*) 'cv30_routines 2382: entree dans cv3_unsat'
     2755!        WRITE(*,*) 'cv30_routines 2382: entree dans cv3_unsat'
    27512756!#endif
    27522757
    … …  
    27772782#ifdef ISO
    27782783          rpprec(il,i)=rp(il,i)
    2779           do ixt=1,ntraciso
     2784          DO ixt=1,ntraciso
    27802785           xtp(ixt,il,i)=xt(ixt,il,i)
    27812786           xtwater(ixt,il,i)=0.0
    … …  
    27842789!-- debug
    27852790#ifdef ISOVERIF
    2786             if(iso_eau.gt.0) then
    2787               call iso_verif_egalite_choix(xt(iso_eau,il,i),rr(il,i), &
    2788      &                  'cv30_unsat 2245 ',errmax,errmaxrel)
    2789              call iso_verif_egalite_choix(xtp(iso_eau,il,i),rp(il,i), &
    2790      &                   'cv30_unsat 2247 ',errmax,errmaxrel)
    2791             endif !if(iso_eau.gt.0) then
     2791            IF(iso_eau.gt.0) THEN
     2792              CALL iso_verif_egalite_choix(xt(iso_eau,il,i),rr(il,i), &
     2793                        'cv30_unsat 2245 ',errmax,errmaxrel)
     2794             CALL iso_verif_egalite_choix(xtp(iso_eau,il,i),rp(il,i), &
     2795                         'cv30_unsat 2247 ',errmax,errmaxrel)
     2796            endif !IF(iso_eau.gt.0) THEN
    27922797#ifdef ISOTRAC
    2793         call iso_verif_traceur(xt(1,il,i),'cv30_routine 2410')
    2794         call iso_verif_traceur(xtp(1,il,i),'cv30_routine 2411')
    2795 #endif             
     2798        CALL iso_verif_traceur(xt(1,il,i),'cv30_routine 2410')
     2799        CALL iso_verif_traceur(xtp(1,il,i),'cv30_routine 2411')
     2800#endif
    27962801#endif
    27972802#endif
    … …  
    28072812  ! enddo
    28082813  ! enddo
    2809   ! ! RomP >>>
     2814  ! RomP >>>
    28102815  DO i = 1, nd
    28112816    DO il = 1, ncum
    … …  
    28142819    END DO
    28152820  END DO
    2816   ! ! RomP <<<
     2821  ! RomP <<<
    28172822
    28182823  ! ***  check whether ep(inb)=0, if so, skip precipitating    ***
    … …  
    28272832  CALL zilch(wdtrain, ncum)
    28282833#ifdef ISO
    2829         call zilch(xtwdtrain,ncum*ntraciso)
     2834        CALL zilch(xtwdtrain,ncum*ntraciso)
    28302835#endif
    28312836
    … …  
    28562861          wdtraina(il, i) = wdtrain(il)/grav !   Pa  26/08/10   RomP
    28572862#ifdef ISO
    2858           do ixt=1,ntraciso
     2863          DO ixt=1,ntraciso
    28592864!           xtwdtrain(ixt,il)=grav*xtep(ixt,il,i)*m(il,i)*xtclw(ixt,il,i)
    28602865           xtwdtrain(ixt,il)=grav*ep(il,i)*m(il,i)*xtclw(ixt,il,i)
    … …  
    28622867!--debug:
    28632868#ifdef ISOVERIF
    2864             if (iso_eau.gt.0) then
    2865               call iso_verif_egalite_choix(xtwdtrain(iso_eau,il), &
    2866      &           wdtrain(il),'cv30_routines 2313',errmax,errmaxrel)
    2867              endif !if (iso_eau.gt.0) then
     2869            IF (iso_eau.gt.0) THEN
     2870              CALL iso_verif_egalite_choix(xtwdtrain(iso_eau,il), &
     2871                 wdtrain(il),'cv30_routines 2313',errmax,errmaxrel)
     2872             endif !if (iso_eau.gt.0) THEN
    28682873#ifdef ISOTRAC
    2869         call iso_verif_traceur(xtwdtrain(1,il),'cv30_routine 2480')       
    2870 #endif             
     2874        CALL iso_verif_traceur(xtwdtrain(1,il),'cv30_routine 2480')
     2875#endif
    28712876#endif
    28722877!--end debug
    … …  
    28772882          wdtraina(il, i) = wdtrain(il)/10. !   Pa  26/08/10   RomP
    28782883#ifdef ISO
    2879           do ixt=1,ntraciso
     2884          DO ixt=1,ntraciso
    28802885!           xtwdtrain(ixt,il)=10.0*xtep(ixt,il,i)*m(il,i)*xtclw(ixt,il,i)
    28812886            xtwdtrain(ixt,il)=10.0*ep(il,i)*m(il,i)*xtclw(ixt,il,i)
    2882             xtwdtraina(ixt,il, i) = xtwdtrain(ixt,il)/10. 
     2887            xtwdtraina(ixt,il, i) = xtwdtrain(ixt,il)/10.
    28832888          enddo
    28842889#endif
    … …  
    28952900            awat = amax1(awat, 0.0)
    28962901#ifdef ISO
    2897 ! precip mixed drafts computed from: xtawat/xtelij = awat/elij           
    2898             if (elij(il,j,i).ne.0.0) then
    2899              do ixt=1,ntraciso
     2902! precip mixed drafts computed from: xtawat/xtelij = awat/elij
     2903            IF (elij(il,j,i).NE.0.0) THEN
     2904             DO ixt=1,ntraciso
    29002905               xtawat(ixt)=xtelij(ixt,il,j,i)*(awat/elij(il,j,i))
    29012906               xtawat(ixt)=amax1(xtawat(ixt),0.0)
    … …  
    29032908!!             xtawat(ixt)=amin1(xtawat(ixt),xtelij(ixt,il,j,i)) !security..
    29042909            else
    2905              do ixt=1,ntraciso
     2910             DO ixt=1,ntraciso
    29062911               xtawat(ixt)=0.0
    29072912             enddo !do ixt=1,niso
    2908             endif                                   
    2909 
    2910 #ifdef ISOVERIF
    2911               if (iso_eau.gt.0) then
    2912                   call iso_verif_egalite_choix(xtawat(iso_eau), &
    2913      &           awat,'cv30_routines 2391',errmax,errmaxrel)
    2914               endif !if (iso_eau.gt.0) then
     2913            endif
     2914
     2915#ifdef ISOVERIF
     2916              IF (iso_eau.gt.0) THEN
     2917                  CALL iso_verif_egalite_choix(xtawat(iso_eau), &
     2918                 awat,'cv30_routines 2391',errmax,errmaxrel)
     2919              endif !if (iso_eau.gt.0) THEN
    29152920#ifdef ISOTRAC
    2916         call iso_verif_traceur(xtawat(1),'cv30_routine 2522')
    2917 #endif               
     2921        CALL iso_verif_traceur(xtawat(1),'cv30_routine 2522')
     2922#endif
    29182923#endif
    29192924#endif
    … …  
    29212926              wdtrain(il) = wdtrain(il) + grav*awat*ment(il, j, i)
    29222927#ifdef ISO
    2923            do ixt=1,ntraciso
     2928           DO ixt=1,ntraciso
    29242929             xtwdtrain(ixt,il)=xtwdtrain(ixt,il) &
    2925      &                         +grav*xtawat(ixt)*ment(il,j,i)
     2930                               +grav*xtawat(ixt)*ment(il,j,i)
    29262931           enddo !do ixt=1,ntraciso
    29272932#endif
    29282933            ELSE
    29292934              wdtrain(il) = wdtrain(il) + 10.0*awat*ment(il, j, i)
    2930 #ifdef ISO           
    2931            do ixt=1,ntraciso
     2935#ifdef ISO
     2936           DO ixt=1,ntraciso
    29322937             xtwdtrain(ixt,il)=xtwdtrain(ixt,il) &
    2933      &                         +10.0*xtawat(ixt)*ment(il,j,i)
     2938                               +10.0*xtawat(ixt)*ment(il,j,i)
    29342939           enddo !!do ixt=1,ntraciso
    29352940#endif
    2936             END IF !if (cvflag_grav) then
     2941            END IF !if (cvflag_grav) THEN
    29372942#ifdef ISO
    29382943!--debug:
    29392944#ifdef ISOVERIF
    2940               if (iso_eau.gt.0) then
    2941                   call iso_verif_egalite_choix(xtwdtrain(iso_eau,il), &
    2942      &           wdtrain(il),'cv30_routines 2366',errmax,errmaxrel)
    2943               endif !if (iso_eau.gt.0) then
     2945              IF (iso_eau.gt.0) THEN
     2946                  CALL iso_verif_egalite_choix(xtwdtrain(iso_eau,il), &
     2947                 wdtrain(il),'cv30_routines 2366',errmax,errmaxrel)
     2948              endif !if (iso_eau.gt.0) THEN
    29442949#ifdef ISOTRAC
    2945         call iso_verif_traceur(xtwdtrain(1,il),'cv30_routine 2540')
    2946         if (option_cond.ge.1) then
     2950        CALL iso_verif_traceur(xtwdtrain(1,il),'cv30_routine 2540')
     2951        IF (option_cond.ge.1) THEN
    29472952           ! on verifie que tout le detrainement est tagge condensat
    2948            if (iso_verif_positif_nostop( &
    2949      &          xtwdtrain(itZonIso(izone_cond,iso_eau),il) &
    2950      &          -xtwdtrain(iso_eau,il), &
    2951      &          'cv30_routines 2795').eq.1) then
    2952           write(*,*) 'xtwdtrain(:,il)=',xtwdtrain(:,il)
    2953           write(*,*) 'xtelij(:,il,j,i)=',xtelij(:,il,j,i)
    2954           write(*,*) 'xtclw(:,il,i)=',xtclw(:,il,i)
     2953           IF (iso_verif_positif_nostop( &
     2954                xtwdtrain(itZonIso(izone_cond,iso_eau),il) &
     2955                -xtwdtrain(iso_eau,il), &
     2956                'cv30_routines 2795').EQ.1) THEN
     2957          WRITE(*,*) 'xtwdtrain(:,il)=',xtwdtrain(:,il)
     2958          WRITE(*,*) 'xtelij(:,il,j,i)=',xtelij(:,il,j,i)
     2959          WRITE(*,*) 'xtclw(:,il,i)=',xtclw(:,il,i)
    29552960          stop
    29562961          endif !if (iso_verif_positif_nostop(Pxtisup(iso_eau,il)-
    2957         endif !if (option_cond.ge.1) then
    2958 #endif             
     2962        endif !if (option_cond.ge.1) THEN
     2963#endif
    29592964#endif
    29602965#endif
    … …  
    30133018        ! jyg1
    30143019        ! cc        sigt=1.0
    3015         ! cc        if(i.ge.icb)sigt=sigp(i)
     3020        ! cc        IF(i.ge.icb)sigt=sigp(i)
    30163021        ! prise en compte de la variation progressive de sigt dans
    30173022        ! les couches icb et icb-1:
    … …  
    30443049!      water(il,i)=max(0.0,water(il,i)) ! ceci est toujours verifie
    30453050#ifdef ISOVERIF
    3046           call iso_verif_positif(water(il,i),'cv30_unsat 2376')
     3051          CALL iso_verif_positif(water(il,i),'cv30_unsat 2376')
    30473052#endif
    30483053!      evap(il,i)=max(0.0,evap(il,i)) ! evap<0 permet la conservation de
    … …  
    31313136          END IF
    31323137
    3133         END IF ! i.eq.1
     3138        END IF ! i.EQ.1
    31343139
    31353140        ! ***       find mixing ratio of precipitating downdraft     ***
    … …  
    31643169            ! :            +tra(il,i,j)*(mp(il,i)-mp(il,i+1))
    31653170            ! trap(il,i,j)=trap(il,i,j)/mp(il,i)
    3166             ! end do
     3171            ! END DO
    31673172
    31683173          ELSE
    … …  
    31813186              ! do j=1,ntra
    31823187              ! trap(il,i,j)=trap(il,i+1,j)
    3183               ! end do
     3188              ! END DO
    31843189
    31853190            END IF
    31863191          END IF
    3187 #ifdef ISO 
    3188         rpprec(il,i)=max(rp(il,i),0.0) 
     3192#ifdef ISO
     3193        rpprec(il,i)=max(rp(il,i),0.0)
    31893194#endif
    31903195          rp(il, i) = amin1(rp(il,i), rs(il,i))
    … …  
    31993204#ifdef ISOVERIF
    32003205! verif des inputs a appel stewart
    3201 !        write(*,*) 'cv30_routines 2842 tmp: appel de appel_stewart'
    3202       do il=1,ncum
    3203        if (i.le.inb(il) .and. lwork(il)) then
    3204          if (iso_eau.gt.0) then
    3205             call iso_verif_egalite_choix(xt(iso_eau,il,i), &
    3206      &        rr(il,i),'appel_stewart 262, cas 1.1',errmax,errmaxrel)
    3207          endif !if (iso_eau.gt.0) then
     3206!        WRITE(*,*) 'cv30_routines 2842 tmp: appel de appel_stewart'
     3207      DO il=1,ncum
     3208       IF (i.le.inb(il) .AND. lwork(il)) THEN
     3209         IF (iso_eau.gt.0) THEN
     3210            CALL iso_verif_egalite_choix(xt(iso_eau,il,i), &
     3211              rr(il,i),'appel_stewart 262, cas 1.1',errmax,errmaxrel)
     3212         endif !if (iso_eau.gt.0) THEN
    32083213!#ifdef ISOTRAC
    3209 !        if (option_tmin.ge.1) then
    3210 !           call iso_verif_positif(xtwater(
     3214!        if (option_tmin.ge.1) THEN
     3215!           CALL iso_verif_positif(xtwater(
    32113216!     :           itZonIso(izone_cond,iso_eau),il,i+1)
    32123217!     :           -xtwater(iso_eau,il,i+1),
    32133218!     :          'cv30_routines 3083')
    3214 !        endif !if (option_tmin.ge.1) then
     3219!        endif !if (option_tmin.ge.1) THEN
    32153220!#endif
    32163221        endif
    … …  
    32183223#endif
    32193224
    3220         if (1.eq.0) then
     3225        IF (1.EQ.0) THEN
    32213226        ! appel de appel_stewart_vectorise
    3222         call appel_stewart_vectall(lwork,ncum, &
    3223      &                   ph,t,evap,xtwdtrain, &
    3224      &                   wdtrain, &
    3225      &            water,rr,xt,rs,rpprec,mp,wt, & ! inputs physiques
    3226      &            xtwater,xtp, &   ! outputs indispensables
    3227      &           xtevap, &    ! diagnostiques
    3228      &          sigd, & ! inputs tunables
    3229      &          i,inb, & ! altitude: car cas particulier en INB
    3230      &          na,nd,nloc,cvflag_grav,ginv,1e-16)
    3231 
    3232         else !if (1.eq.0) then
     3227        CALL appel_stewart_vectall(lwork,ncum, &
     3228                         ph,t,evap,xtwdtrain, &
     3229                         wdtrain, &
     3230                  water,rr,xt,rs,rpprec,mp,wt, & ! inputs physiques
     3231                  xtwater,xtp, &   ! outputs indispensables
     3232                 xtevap, &    ! diagnostiques
     3233                sigd, & ! inputs tunables
     3234                i,inb, & ! altitude: car cas particulier en INB
     3235                na,nd,nloc,cvflag_grav,ginv,1e-16)
     3236
     3237        else !if (1.EQ.0) THEN
    32333238          ! truc simple sans fractionnement
    32343239          ! juste pour debuggage
    3235           call appel_stewart_debug(lwork,nloc,inb,na,i, &
     3240          CALL appel_stewart_debug(lwork,nloc,inb,na,i, &
    32363241                evap,water,rpprec,rr,wdtrain, &
    32373242                xtevap,xtwater,xtp,xt,xtwdtrain)
    3238         endif ! if (1.eq.0) then
    3239 
    3240 
    3241 #ifdef ISOVERIF
    3242 !        write(*,*) 'cv30_routines 2864 tmp: sortie de appel_stewart'
     3243        endif ! if (1.EQ.0) THEN
     3244#ifdef ISOVERIF
     3245!        WRITE(*,*) 'cv30_routines 2864 tmp: sortie de appel_stewart'
    32433246! verif des outputs de appel stewart
    3244        do il=1,ncum
    3245         if (i.le.inb(il) .and. lwork(il)) then
    3246          do ixt=1,ntraciso       
    3247           call iso_verif_noNAN(xtp(ixt,il,i),'cv30_unsat 3382')
    3248           call iso_verif_noNAN(xtwater(ixt,il,i),'cv30_unsat 3381')
    3249           call iso_verif_noNAN(xtevap(ixt,il,i),'cv30_unsat 2661')
    3250          enddo 
    3251          if (iso_eau.gt.0) then
    3252           call iso_verif_egalite_choix(xtp(iso_eau,il,i), &
    3253      &           rpprec(il,i),'cv30_unsat 2736',errmax,errmaxrel) 
    3254           call iso_verif_egalite_choix(xtwater(iso_eau,il,i), &
    3255      &           water(il,i),'cv30_unsat 2747',errmax,errmaxrel)   
    3256 !         write(*,*) 'xtwater(4,il,i)=',xtwater(4,il,i)
    3257 !         write(*,*) 'water(il,i)=',water(il,i)
    3258           call iso_verif_egalite_choix(xtevap(iso_eau,il,i), &
    3259      &           evap(il,i),'cv30_unsat 2751',errmax,errmaxrel)
    3260          endif !if (iso_eau.gt.0) then
    3261          if ((iso_HDO.gt.0).and. &
    3262      &           (rp(il,i).gt.ridicule)) then
    3263            call iso_verif_aberrant(xtp(iso_HDO,il,i)/rpprec(il,i), &
    3264      &                  'cv3unsat 2756')
    3265            endif !if ((iso_HDO.gt.0).and.
     3247       DO il=1,ncum
     3248        IF (i.le.inb(il) .AND. lwork(il)) THEN
     3249         DO ixt=1,ntraciso
     3250          CALL iso_verif_noNAN(xtp(ixt,il,i),'cv30_unsat 3382')
     3251          CALL iso_verif_noNAN(xtwater(ixt,il,i),'cv30_unsat 3381')
     3252          CALL iso_verif_noNAN(xtevap(ixt,il,i),'cv30_unsat 2661')
     3253         enddo
     3254         IF (iso_eau.gt.0) THEN
     3255          CALL iso_verif_egalite_choix(xtp(iso_eau,il,i), &
     3256                 rpprec(il,i),'cv30_unsat 2736',errmax,errmaxrel)
     3257          CALL iso_verif_egalite_choix(xtwater(iso_eau,il,i), &
     3258                 water(il,i),'cv30_unsat 2747',errmax,errmaxrel)
     3259!         WRITE(*,*) 'xtwater(4,il,i)=',xtwater(4,il,i)
     3260!         WRITE(*,*) 'water(il,i)=',water(il,i)
     3261          CALL iso_verif_egalite_choix(xtevap(iso_eau,il,i), &
     3262                 evap(il,i),'cv30_unsat 2751',errmax,errmaxrel)
     3263         endif !if (iso_eau.gt.0) THEN
     3264         IF ((iso_HDO.gt.0).AND. &
     3265                 (rp(il,i).gt.ridicule)) THEN
     3266           CALL iso_verif_aberrant(xtp(iso_HDO,il,i)/rpprec(il,i), &
     3267                        'cv3unsat 2756')
     3268           endif !if ((iso_HDO.gt.0).AND.
    32663269#ifdef ISOTRAC
    3267 !        if (il.eq.602) then
    3268 !        write(*,*) 'cv30_routine tmp: il,i=',il,i
    3269 !        write(*,*) 'xtp(iso_eau:ntraciso:3,il,i)=',
     3270!        if (il.EQ.602) THEN
     3271!        WRITE(*,*) 'cv30_routine tmp: il,i=',il,i
     3272!        WRITE(*,*) 'xtp(iso_eau:ntraciso:3,il,i)=',
    32703273!     :          xtp(iso_eau:ntraciso:3,il,i)
    32713274!        endif
    3272         call iso_verif_traceur(xtp(1,il,i),'cv30_routine 2852')
    3273         call iso_verif_traceur(xtwater(1,il,1), &
    3274      &       'cv30_routine 2853 unsat apres appel')
    3275         call iso_verif_traceur_pbidouille(xtwater(1,il,i), &
    3276      &           'cv30_routine 2853b')
    3277         call iso_verif_traceur_justmass(xtevap(1,il,i), &
    3278      &                    'cv30_routine 2854')
    3279 !        if (option_tmin.ge.1) then
    3280 !         call iso_verif_positif(xtwater(
     3275        CALL iso_verif_traceur(xtp(1,il,i),'cv30_routine 2852')
     3276        CALL iso_verif_traceur(xtwater(1,il,1), &
     3277             'cv30_routine 2853 unsat apres appel')
     3278        CALL iso_verif_traceur_pbidouille(xtwater(1,il,i), &
     3279                 'cv30_routine 2853b')
     3280        CALL iso_verif_traceur_justmass(xtevap(1,il,i), &
     3281                          'cv30_routine 2854')
     3282!        if (option_tmin.ge.1) THEN
     3283!         CALL iso_verif_positif(xtwater(
    32813284!     :           itZonIso(izone_cond,iso_eau),il,i)
    32823285!     :           -xtwater(iso_eau,il,i),
    32833286!     :          'cv30_routines 3143')
    3284 !        endif !if (option_tmin.ge.1) then
    3285 #endif             
    3286         endif !if (i.le.inb(il) .and. lwork(il)) then       
     3287!        endif !if (option_tmin.ge.1) THEN
     3288#endif
     3289        endif !if (i.le.inb(il) .AND. lwork(il)) THEN
    32873290       enddo !do il=1,ncum
    32883291#endif
    3289        
     3292
    32903293! equivalent isotopique de rp(il,i)=amin1(rp(il,i),rs(il,i))
    3291        do il=1,ncum
    3292         if (i.lt.inb(il) .and. lwork(il)) then
    3293 
    3294          if (rpprec(il,i).gt.rs(il,i)) then
    3295             if (rs(il,i).le.0) then
    3296                 write(*,*) 'cv3unsat 2640'
     3294       DO il=1,ncum
     3295        IF (i.lt.inb(il) .AND. lwork(il)) THEN
     3296         IF (rpprec(il,i).gt.rs(il,i)) THEN
     3297            IF (rs(il,i).le.0) THEN
     3298                WRITE(*,*) 'cv3unsat 2640'
    32973299                stop
    32983300            endif
    3299             do ixt=1,ntraciso
     3301            DO ixt=1,ntraciso
    33003302              xtp(ixt,il,i)=xtp(ixt,il,i)/rpprec(il,i)*rs(il,i)
    33013303              xtp(ixt,il,i)=max(0.0,xtp(ixt,il,i))
    3302             enddo !do ixt=1,niso 
    3303 #ifdef ISOVERIF
    3304            do ixt=1,ntraciso       
    3305            call iso_verif_noNaN(xtp(ixt,il,i),'cv3unsat 2641')               
     3304            enddo !do ixt=1,niso
     3305#ifdef ISOVERIF
     3306           DO ixt=1,ntraciso
     3307           CALL iso_verif_noNaN(xtp(ixt,il,i),'cv3unsat 2641')
    33063308           enddo !do ixt=1,niso
    3307            if (iso_eau.gt.0) then
    3308 !             write(*,*) 'xtp(iso_eau,il,i)=',xtp(iso_eau,il,i) 
    3309              call iso_verif_egalite_choix(xtp(iso_eau,il,i),rp(il,i), &
    3310      &                  'cv3unsat 2653',errmax,errmaxrel)
    3311              call iso_verif_egalite_choix(xtp(iso_eau,il,i), &
    3312      &            rs(il,i),'cv3unsat 2654',errmax,errmaxrel)   
    3313            endif 
    3314            if ((iso_HDO.gt.0).and. &
    3315      &           (rp(il,i).gt.ridicule)) then
    3316              if (iso_verif_aberrant_nostop(xtp(iso_HDO,il,i)/rp(il,i), &
    3317      &                  'cv3unsat 2658').eq.1) then
    3318                 write(*,*) 'rpprec(il,i),rs(il,i),rp(il,i)=', &
    3319      &                   rpprec(il,i),rs(il,i),rp(il,i)
     3309           IF (iso_eau.gt.0) THEN
     3310!             WRITE(*,*) 'xtp(iso_eau,il,i)=',xtp(iso_eau,il,i)
     3311             CALL iso_verif_egalite_choix(xtp(iso_eau,il,i),rp(il,i), &
     3312                        'cv3unsat 2653',errmax,errmaxrel)
     3313             CALL iso_verif_egalite_choix(xtp(iso_eau,il,i), &
     3314                  rs(il,i),'cv3unsat 2654',errmax,errmaxrel)
     3315           endif
     3316           IF ((iso_HDO.gt.0).AND. &
     3317                 (rp(il,i).gt.ridicule)) THEN
     3318             IF (iso_verif_aberrant_nostop(xtp(iso_HDO,il,i)/rp(il,i), &
     3319                        'cv3unsat 2658').EQ.1) THEN
     3320                WRITE(*,*) 'rpprec(il,i),rs(il,i),rp(il,i)=', &
     3321                         rpprec(il,i),rs(il,i),rp(il,i)
    33203322                stop
    33213323             endif
    33223324           endif
    33233325#ifdef ISOTRAC
    3324         call iso_verif_traceur(xtp(1,il,i),'cv30_routine 2893')
    3325 #endif           
    3326 #endif
    3327           rpprec(il,i)=rs(il,i)           
    3328          endif !if (rp(il,i).gt.rs(il,i)) then           
     3326        CALL iso_verif_traceur(xtp(1,il,i),'cv30_routine 2893')
     3327#endif
     3328#endif
     3329          rpprec(il,i)=rs(il,i)
     3330         endif !if (rp(il,i).gt.rs(il,i)) THEN
    33293331         endif !if (i.lt.INB et lwork)
    33303332        enddo ! il=1,ncum
    … …  
    33353337
    33363338! fin de la boucle en i (altitude)
    3337 #ifdef ISO   
    3338       write(*,*) 'nl=',nl,'nd=',nd,'; ncum=',ncum 
    3339 #ifdef ISOVERIF
    3340       do i=1,nl !nl
    3341         do il=1,ncum
    3342         if (iso_eau.gt.0) then
    3343 !            write(*,*) 'cv30_routines 2767:i,il,lwork(il),inb(il)=',
     3339#ifdef ISO
     3340      WRITE(*,*) 'nl=',nl,'nd=',nd,'; ncum=',ncum
     3341#ifdef ISOVERIF
     3342      DO i=1,nl !nl
     3343        DO il=1,ncum
     3344        IF (iso_eau.gt.0) THEN
     3345!            WRITE(*,*) 'cv30_routines 2767:i,il,lwork(il),inb(il)=',
    33443346!     :           i,il,lwork(il),inb(il)
    3345 !            write(*,*) 'rp(il,i),xtp(iso_eau,il,i)=',
    3346 !     :           rp(il,i),xtp(iso_eau,il,i) 
    3347             call iso_verif_egalite_choix(xt(iso_eau,il,i), &
    3348      &           rr(il,i),'cv30_unsat 2668',errmax,errmaxrel)
    3349             call iso_verif_egalite_choix(xtp(iso_eau,il,i), &
    3350      &           rp(il,i),'cv30_unsat 2670',errmax,errmaxrel)
    3351            call iso_verif_egalite_choix(xtwater(iso_eau,il,i), &
    3352      &           water(il,i),'cv30_unsat 2672',errmax,errmaxrel)
    3353         endif !if (iso_eau.gt.0) then
     3347!            WRITE(*,*) 'rp(il,i),xtp(iso_eau,il,i)=',
     3348!     :           rp(il,i),xtp(iso_eau,il,i)
     3349            CALL iso_verif_egalite_choix(xt(iso_eau,il,i), &
     3350                 rr(il,i),'cv30_unsat 2668',errmax,errmaxrel)
     3351            CALL iso_verif_egalite_choix(xtp(iso_eau,il,i), &
     3352                 rp(il,i),'cv30_unsat 2670',errmax,errmaxrel)
     3353           CALL iso_verif_egalite_choix(xtwater(iso_eau,il,i), &
     3354                 water(il,i),'cv30_unsat 2672',errmax,errmaxrel)
     3355        endif !if (iso_eau.gt.0) THEN
    33543356!#ifdef ISOTRAC
    33553357!        if (iso_verif_traceur_choix_nostop(xtwater(1,il,i),
    33563358!     :       'cv30_routine 2982 unsat',errmax,
    3357 !     :       errmaxrel,ridicule_trac,deltalimtrac).eq.1) then
    3358 !              write(*,*) 'il,i,inb(il),lwork(il)=',
     3359!     :       errmaxrel,ridicule_trac,deltalimtrac).EQ.1) THEN
     3360!              WRITE(*,*) 'il,i,inb(il),lwork(il)=',
    33593361!     :           il,i,inb(il),lwork(il)
    3360 !              write(*,*) 'xtwater(:,il,i)=',xtwater(:,il,i)
     3362!              WRITE(*,*) 'xtwater(:,il,i)=',xtwater(:,il,i)
    33613363!              stop
    33623364!        endif
    3363 !#endif       
     3365!#endif
    33643366        enddo !do il=1,nloc!ncum
    33653367      enddo !do i=1,nl!nl
    33663368      il=5
    3367       i=39 
    3368       write(*,*) 'cv30_unsat 2780: il,water(il,i),xtwater(iso_eau,il,i)=' &
     3369      i=39
     3370      WRITE(*,*) 'cv30_unsat 2780: il,water(il,i),xtwater(iso_eau,il,i)=' &
    33693371               ,il,water(il,i),xtwater(iso_eau,il,i)
    33703372#endif
    33713373#endif
    3372   RETURN
     3374
    33733375END SUBROUTINE cv30_unsat
    33743376
    … …  
    33793381    mike, tls, tps, qcondc, wd &
    33803382#ifdef ISO
    3381      &                    ,xt,xtclw,xtp,xtwater,xtevap &
    3382      &                    ,xtent,xtelij,xtprecip,fxt,xtVprecip &
     3383                          ,xt,xtclw,xtp,xtwater,xtevap &
     3384                          ,xtent,xtelij,xtprecip,fxt,xtVprecip &
    33833385#ifdef DIAGISO
    3384      &          ,fq_detrainement,fq_ddft,fq_fluxmasse,fq_evapprecip &
    3385      &          ,fxt_detrainement,fxt_ddft,fxt_fluxmasse,fxt_evapprecip &
    3386      &         ,f_detrainement,q_detrainement,xt_detrainement  &
    3387 #endif     
    3388 #endif
    3389      &                    )
    3390 #ifdef ISO
    3391     use infotrac_phy, ONLY: ntraciso=>ntiso, niso, nzone, itZonIso
    3392     use isotopes_mod, ONLY: essai_convergence,ridicule,iso_eau,iso_HDO,iso_O18
    3393 #ifdef ISOVERIF
    3394     use isotopes_verif_mod, ONLY: errmax,errmaxrel, &
     3386                ,fq_detrainement,fq_ddft,fq_fluxmasse,fq_evapprecip &
     3387                ,fxt_detrainement,fxt_ddft,fxt_fluxmasse,fxt_evapprecip &
     3388               ,f_detrainement,q_detrainement,xt_detrainement  &
     3389#endif
     3390#endif
     3391                          )
     3392        USE conema3_mod_h
     3393#ifdef ISO
     3394    USE infotrac_phy, ONLY: ntraciso=>ntiso, niso, nzone, itZonIso
     3395    USE isotopes_mod, ONLY: essai_convergence,ridicule,iso_eau,iso_HDO,iso_O18
     3396#ifdef ISOVERIF
     3397    USE isotopes_verif_mod, ONLY: errmax,errmaxrel, &
    33953398        iso_verif_egalite_choix, iso_verif_noNaN,iso_verif_aberrant, &
    33963399        iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
    … …  
    34013404#endif
    34023405#ifdef ISOTRAC
    3403         use isotrac_mod, only: option_traceurs, &
     3406        USE isotrac_mod, ONLY: option_traceurs, &
    34043407        izone_revap,izone_poubelle,izone_ddft
    34053408#ifdef ISOVERIF
    3406     use isotopes_verif_mod, ONLY: iso_verif_traceur_choix_nostop,deltalimtrac, &
     3409    USE isotopes_verif_mod, ONLY: iso_verif_traceur_choix_nostop,deltalimtrac, &
    34073410&       iso_verif_tracpos_choix_nostop,iso_verif_traceur,iso_verif_traceur_justmass
    3408     use isotrac_mod, only: ridicule_trac
    3409 #endif
    3410 #endif
    3411 #endif
    3412 
    3413   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    3414           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    3415   USE cvflag_mod_h, ONLY: icvflag_Tpa, cvflag_grav, cvflag_ice, ok_optim_yield, ok_entrain, ok_homo_tend, &
    3416           ok_convstop, ok_intermittent, cvflag_prec_eject, qsat_depends_on_qt, adiab_ascent_mass_flux_depends_on_ejectliq, keepbug_ice_frac
     3411    USE isotrac_mod, ONLY: ridicule_trac
     3412#endif
     3413#endif
     3414#endif
     3415USE cvflag_mod_h
     3416USE cvthermo_mod_h
     3417
    34173418  IMPLICIT NONE
    3418 
    3419   include "cv30param.h"
    3420   include "conema3.h"
    3421 
    34223419  ! inputs:
    34233420  INTEGER ncum, nd, na, ntra, nloc
    … …  
    34393436  REAL tv(nloc, nd), tvp(nloc, nd)
    34403437#ifdef ISO
    3441       real xt(ntraciso,nloc,nd)
     3438      REAL xt(ntraciso,nloc,nd)
    34423439!      real xtep(ntraciso,nloc,na) ! le 7 mai: on supprime xtep
    3443       real xtclw(ntraciso,nloc,na), xtp(ntraciso,nloc,na)
    3444       real xtwater(ntraciso,nloc,na), xtevap(ntraciso,nloc,na)
    3445       real xtent(ntraciso,nloc,na,na), xtelij(ntraciso,nloc,na,na)
    3446 #ifdef ISOVERIF     
     3440      REAL xtclw(ntraciso,nloc,na), xtp(ntraciso,nloc,na)
     3441      REAL xtwater(ntraciso,nloc,na), xtevap(ntraciso,nloc,na)
     3442      REAL xtent(ntraciso,nloc,na,na), xtelij(ntraciso,nloc,na,na)
     3443#ifdef ISOVERIF
    34473444      CHARACTER (LEN=20) :: modname='cv30_compress'
    34483445      CHARACTER (LEN=80) :: abort_message
    … …  
    34643461  REAL wd(nloc) ! gust
    34653462#ifdef ISO
    3466       real xtprecip(ntraciso,nloc), fxt(ntraciso,nloc,nd)
    3467       real xtVprecip(ntraciso,nloc,nd+1)
     3463      REAL xtprecip(ntraciso,nloc), fxt(ntraciso,nloc,nd)
     3464      REAL xtVprecip(ntraciso,nloc,nd+1)
    34683465#endif
    34693466
    … …  
    34813478  REAL siga(nloc, nd), sax(nloc, nd), mac(nloc, nd) ! cld
    34823479#ifdef ISO
    3483       integer ixt
    3484       real xtbx(ntraciso), xtawat(ntraciso)
     3480      INTEGER ixt
     3481      REAL xtbx(ntraciso), xtawat(ntraciso)
    34853482      ! cam debug
    34863483      ! pour l'homogeneisation sous le nuage:
    3487       real frsum(nloc), bxtsum(ntraciso,nloc), fxtsum(ntraciso,nloc)
     3484      REAL frsum(nloc), bxtsum(ntraciso,nloc), fxtsum(ntraciso,nloc)
    34883485      ! correction dans calcul tendance liee a Am:
    3489       real dq_tmp,k_tmp,dx_tmp,R_tmp,dqreste_tmp,dxreste_tmp,kad_tmp
    3490       logical correction_excess_aberrant
    3491       parameter (correction_excess_aberrant=.false.)
     3486      REAL dq_tmp,k_tmp,dx_tmp,R_tmp,dqreste_tmp,dxreste_tmp,kad_tmp
     3487      LOGICAL correction_excess_aberrant
     3488      parameter (correction_excess_aberrant=.FALSE.)
    34923489        ! correction qui permettait d'eviter deltas et dexcess aberrants. Mais
    34933490        ! pb: ne conserve pas la masse d'isotopes!
    34943491#ifdef DIAGISO
    34953492        ! diagnostiques juste: tendance des differents processus
    3496       real fxt_detrainement(ntraciso,nloc,nd)
    3497       real fxt_fluxmasse(ntraciso,nloc,nd)
    3498       real fxt_evapprecip(ntraciso,nloc,nd)
    3499       real fxt_ddft(ntraciso,nloc,nd)
    3500       real fq_detrainement(nloc,nd)
    3501       real q_detrainement(nloc,nd)
    3502       real xt_detrainement(ntraciso,nloc,nd)
    3503       real f_detrainement(nloc,nd)
    3504       real fq_fluxmasse(nloc,nd)
    3505       real fq_evapprecip(nloc,nd)
    3506       real fq_ddft(nloc,nd)
    3507 #endif     
     3493      REAL fxt_detrainement(ntraciso,nloc,nd)
     3494      REAL fxt_fluxmasse(ntraciso,nloc,nd)
     3495      REAL fxt_evapprecip(ntraciso,nloc,nd)
     3496      REAL fxt_ddft(ntraciso,nloc,nd)
     3497      REAL fq_detrainement(nloc,nd)
     3498      REAL q_detrainement(nloc,nd)
     3499      REAL xt_detrainement(ntraciso,nloc,nd)
     3500      REAL f_detrainement(nloc,nd)
     3501      REAL fq_fluxmasse(nloc,nd)
     3502      REAL fq_evapprecip(nloc,nd)
     3503      REAL fq_ddft(nloc,nd)
     3504#endif
    35083505!#ifdef ISOVERIF
    35093506!      integer iso_verif_aberrant_nostop
    35103507!      real deltaD
    3511 !#endif     
    3512 #ifdef ISOTRAC     
     3508!#endif
     3509#ifdef ISOTRAC
    35133510!      integer iso_verif_traceur_choix_nostop
    35143511!      integer iso_verif_tracpos_choix_nostop
    3515       real xtnew(ntraciso)
     3512      REAL xtnew(ntraciso)
    35163513!      real conversion(niso)
    3517       real fxtYe(niso)
    3518       real fxtqe(niso)
    3519       real fxtXe(niso)
    3520       real fxt_revap(niso)
    3521       real Xe(niso)
    3522       integer ixt_revap,izone
    3523       integer ixt_poubelle, ixt_ddft,iiso
     3514      REAL fxtYe(niso)
     3515      REAL fxtqe(niso)
     3516      REAL fxtXe(niso)
     3517      REAL fxt_revap(niso)
     3518      REAL Xe(niso)
     3519      INTEGER ixt_revap,izone
     3520      INTEGER ixt_poubelle, ixt_ddft,iiso
    35243521#endif
    35253522#endif
    … …  
    35383535#ifdef ISO
    35393536       ! cam debug
    3540 !       write(*,*) 'cv30_routines 3082: entree dans cv3_yield'
     3537!       WRITE(*,*) 'cv30_routines 3082: entree dans cv3_yield'
    35413538       ! en cam debug
    3542        do ixt = 1, ntraciso
     3539       DO ixt = 1, ntraciso
    35433540        xtprecip(ixt,il)=0.0
    35443541        xtVprecip(ixt,il,nd+1)=0.0
    … …  
    35583555      nqcond(il, i) = 0.0 ! cld
    35593556#ifdef ISO
    3560          do ixt = 1, ntraciso
     3557         DO ixt = 1, ntraciso
    35613558          fxt(ixt,il,i)=0.0
    35623559          xtVprecip(ixt,il,i)=0.0
    … …  
    35693566        fq_evapprecip(il,i)=0.0
    35703567        fq_ddft(il,i)=0.0
    3571         do ixt = 1, niso
     3568        DO ixt = 1, niso
    35723569          fxt_fluxmasse(ixt,il,i)=0.0
    35733570          fxt_detrainement(ixt,il,i)=0.0
    … …  
    35753572          fxt_evapprecip(ixt,il,i)=0.0
    35763573          fxt_ddft(ixt,il,i)=0.0
    3577         enddo 
    3578 #endif                     
     3574        enddo
     3575#endif
    35793576#endif
    35803577    END DO
    … …  
    36053602
    36063603#ifdef ISO
    3607          do ixt = 1, ntraciso
     3604         DO ixt = 1, ntraciso
    36083605          xtprecip(ixt,il)=wt(il,1)*sigd*xtwater(ixt,il,1) &
    3609      &                      *86400.*1000./(rowl*grav) ! en mm/jour
     3606                            *86400.*1000./(rowl*grav) ! en mm/jour
    36103607         enddo
    36113608         ! cam verif
    36123609#ifdef ISOVERIF
    3613           if (iso_eau.gt.0) then
    3614 !              write(*,*) 'cv30_yield 2952: '//
     3610          IF (iso_eau.gt.0) THEN
     3611!              WRITE(*,*) 'cv30_yield 2952: '//
    36153612!     :           'il,water(il,1),xtwater(iso_eau,il,1)='
    36163613!     :           ,il,water(il,1),xtwater(iso_eau,il,1)
    3617               call iso_verif_egalite_choix(xtwater(iso_eau,il,1), &
    3618      &           water(il,1),'cv30_routines 2959', &
    3619      &           errmax,errmaxrel)
     3614              CALL iso_verif_egalite_choix(xtwater(iso_eau,il,1), &
     3615                 water(il,1),'cv30_routines 2959', &
     3616                 errmax,errmaxrel)
    36203617                !Rq: wt(il,1)*sigd*86400.*1000./(rowl*grav)=3964.6565
    36213618                ! -> on auatorise 3e3 fois plus d'erreur dans precip
    3622               call iso_verif_egalite_choix(xtprecip(iso_eau,il), &
    3623      &           precip(il),'cv30_routines 3138', &
    3624      &           errmax*4e3,errmaxrel)
    3625           endif !if (iso_eau.gt.0) then
     3619              CALL iso_verif_egalite_choix(xtprecip(iso_eau,il), &
     3620                 precip(il),'cv30_routines 3138', &
     3621                 errmax*4e3,errmaxrel)
     3622          endif !if (iso_eau.gt.0) THEN
    36263623#ifdef ISOTRAC
    3627         call iso_verif_traceur(xtwater(1,il,1), &
    3628      &       'cv30_routine 3146')
    3629         if (iso_verif_traceur_choix_nostop(xtprecip(1,il), &
    3630      &           'cv30_routine 3147',errmax*1e2, &
    3631      &       errmaxrel,ridicule_trac,deltalimtrac).eq.1) then
    3632           write(*,*) 'il,inb(il)=',il,inb(il)
    3633           write(*,*) 'xtwater(:,il,1)=',xtwater(:,il,1)
    3634           write(*,*) 'xtprecip(:,il)=',xtprecip(:,il)
    3635           write(*,*) 'fac=',wt(il,1)*sigd*86400.*1000./(rowl*grav)
     3624        CALL iso_verif_traceur(xtwater(1,il,1), &
     3625             'cv30_routine 3146')
     3626        IF (iso_verif_traceur_choix_nostop(xtprecip(1,il), &
     3627                 'cv30_routine 3147',errmax*1e2, &
     3628             errmaxrel,ridicule_trac,deltalimtrac).EQ.1) THEN
     3629          WRITE(*,*) 'il,inb(il)=',il,inb(il)
     3630          WRITE(*,*) 'xtwater(:,il,1)=',xtwater(:,il,1)
     3631          WRITE(*,*) 'xtprecip(:,il)=',xtprecip(:,il)
     3632          WRITE(*,*) 'fac=',wt(il,1)*sigd*86400.*1000./(rowl*grav)
    36363633          stop
    36373634        endif
    3638 #endif           
     3635#endif
    36393636#endif
    36403637          ! end cam verif
    … …  
    36433640        precip(il) = wt(il, 1)*sigd*water(il, 1)*8640.
    36443641#ifdef ISO
    3645          do ixt = 1, ntraciso
     3642         DO ixt = 1, ntraciso
    36463643          xtprecip(ixt,il)=wt(il,1)*sigd*xtwater(ixt,il,1)*8640.
    36473644         enddo
    36483645         ! cam verif
    3649 #ifdef ISOVERIF         
    3650           if (iso_eau.gt.0) then
    3651               call iso_verif_egalite_choix(xtprecip(iso_eau,il), &
    3652      &           precip(il),'cv30_routines 3139', &
    3653      &           errmax,errmaxrel)
    3654           endif !if (iso_eau.gt.0) then
     3646#ifdef ISOVERIF
     3647          IF (iso_eau.gt.0) THEN
     3648              CALL iso_verif_egalite_choix(xtprecip(iso_eau,il), &
     3649                 precip(il),'cv30_routines 3139', &
     3650                 errmax,errmaxrel)
     3651          endif !if (iso_eau.gt.0) THEN
    36553652#ifdef ISOTRAC
    3656         call iso_verif_traceur(xtprecip(1,il),'cv30_routine 3166')
    3657 #endif         
     3653        CALL iso_verif_traceur(xtprecip(1,il),'cv30_routine 3166')
     3654#endif
    36583655#endif
    36593656         ! end cam verif
    … …  
    36723669          vprecip(il, k) = wt(il, k)*sigd*water(il, k)/grav
    36733670#ifdef ISO
    3674              do ixt=1,ntraciso
     3671             DO ixt=1,ntraciso
    36753672               xtVPrecip(ixt,il,k) = wt(il,k)*sigd &
    3676      &          *xtwater(ixt,il,k)/grav
     3673                *xtwater(ixt,il,k)/grav
    36773674             enddo
    36783675#endif
    … …  
    36803677          vprecip(il, k) = wt(il, k)*sigd*water(il, k)/10.
    36813678#ifdef ISO
    3682              do ixt=1,ntraciso
     3679             DO ixt=1,ntraciso
    36833680               xtVPrecip(ixt,il,k) = wt(il,k)*sigd &
    3684      &          *xtwater(ixt,il,k)/10.0
     3681                *xtwater(ixt,il,k)/10.0
    36853682             enddo
    36863683#endif
    … …  
    36943691  ! ***  NE PAS UTILISER POUR L'INSTANT ***
    36953692
    3696   ! !      do il=1,ncum
    3697   ! !        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
    3698   ! !     :                                  /(sigd*p(il,icb(il)))
    3699   ! !      enddo
     3693  !      do il=1,ncum
     3694  !        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
     3695  !     :                                  /(sigd*p(il,icb(il)))
     3696  !      enddo
    37003697
    37013698
    … …  
    37523749      fr(il, 1) = fr(il, 1) + 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
    37533750
    3754 #ifdef ISO   
     3751#ifdef ISO
    37553752        ! juste Mp et evap pour l'instant, voir plus bas pour am
    3756        do ixt = 1, ntraciso
     3753       DO ixt = 1, ntraciso
    37573754        fxt(ixt,il,1)= &
    3758      &         0.01*grav*mp(il,2)*(xtp(ixt,il,2)-xt(ixt,il,1))*work(il) &
    3759      &       +sigd*0.5*(xtevap(ixt,il,1)+xtevap(ixt,il,2))
    3760 !c+tard     :          +sigd*xtevap(ixt,il,1)     
     3755               0.01*grav*mp(il,2)*(xtp(ixt,il,2)-xt(ixt,il,1))*work(il) &
     3756             +sigd*0.5*(xtevap(ixt,il,1)+xtevap(ixt,il,2))
     3757!c+tard     :          +sigd*xtevap(ixt,il,1)
    37613758       enddo !do ixt = 1, ntraciso       ! pour water tagging option 6: pas besoin ici de faire de conversion.
    37623759
    37633760#ifdef DIAGISO
    37643761        fq_ddft(il,1)=fq_ddft(il,1) &
    3765      &           +0.01*grav*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
     3762                 +0.01*grav*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
    37663763        fq_evapprecip(il,1)=fq_evapprecip(il,1) &
    3767      &          +sigd*0.5*(evap(il,1)+evap(il,2))
     3764                +sigd*0.5*(evap(il,1)+evap(il,2))
    37683765        fq_fluxmasse(il,1)=fq_fluxmasse(il,1) &
    3769      &           +0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
    3770         do ixt = 1, ntraciso
     3766                 +0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
     3767        DO ixt = 1, ntraciso
    37713768!        fxt_fluxmasse(ixt,il,1)=fxt_fluxmasse(ixt,il,1) &
    37723769!     &      +0.01*grav*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il) ! deplace
    37733770!     plus haut car il existe differents cas
    37743771        fxt_ddft(ixt,il,1)=fxt_ddft(ixt,il,1) &
    3775      &      +0.01*grav*mp(il,2)*(xtp(ixt,il,2)-xt(ixt,il,1))*work(il)
     3772            +0.01*grav*mp(il,2)*(xtp(ixt,il,2)-xt(ixt,il,1))*work(il)
    37763773        fxt_evapprecip(ixt,il,1)=fxt_evapprecip(ixt,il,1) &
    3777      &           +sigd*0.5*(xtevap(ixt,il,1)+xtevap(ixt,il,2))
     3774                 +sigd*0.5*(xtevap(ixt,il,1)+xtevap(ixt,il,2))
    37783775        enddo
    3779 #endif     
     3776#endif
    37803777
    37813778
    … …  
    37873784        ! Mais on plante dans un cas pathologique en decembre 2017 lors du test
    37883785        ! d'un cas d'Anne Cozic: les isotopes deviennent negatifs.
    3789         ! C'est un cas pas physique: on perd 99% de la masse de vapeur d'eau! 
     3786        ! C'est un cas pas physique: on perd 99% de la masse de vapeur d'eau!
    37903787        ! q2=1.01e-3 et q1=1.25e-3 kg/kg
    37913788        ! et dq=-1.24e-3: comment est-ce possible qu'un flux venant d'un air a
    … …  
    37973794        ! sortant.
    37983795        ! Ainsi, le flux de masse sortant ne modifie pas la composition
    3799         ! isotopique de la vapeur d'eau q1. 
     3796        ! isotopique de la vapeur d'eau q1.
    38003797        ! A la fin, on a R=(x1+dx)/(q1+dq)=(x1+k*x2)/(q1+k*q2)
    38013798        ! On verifie que quand k est petit, on tend vers la formulation
    … …  
    38103807        ! calcule R_tmp.
    38113808        dq_tmp=0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)*delt ! utile ci-dessous
    3812         if ((dq_tmp/rr(il,1).lt.-0.9).and.correction_excess_aberrant) then
     3809        IF ((dq_tmp/rr(il,1).lt.-0.9).AND.correction_excess_aberrant) THEN
    38133810                ! nouvelle formulation ou on fait d'abord entrer k*q2 et ensuite
    38143811                ! seulement on fait sortir k*q1 sans changement de composition
    … …  
    38163813             k_tmp=0.01*grav*am(il)*work(il)*delt
    38173814             dqreste_tmp= 0.01*grav*mp(il, 2)*(rp(il,2)-rr(il,1))*work(il)*delt + &
    3818      &                   sigd*0.5*(evap(il,1)+evap(il,2))*delt
    3819              do ixt = 1, ntraciso
     3815                         sigd*0.5*(evap(il,1)+evap(il,2))*delt
     3816             DO ixt = 1, ntraciso
    38203817                dxreste_tmp= 0.01*grav*mp(il,2)*(xtp(ixt,il,2)-xt(ixt,il,1))*work(il)*delt &
    3821      &                  +sigd*0.5*(xtevap(ixt,il,1)+xtevap(ixt,il,2))*delt
     3818                        +sigd*0.5*(xtevap(ixt,il,1)+xtevap(ixt,il,2))*delt
    38223819                R_tmp=(xt(ixt,il,1)+dxreste_tmp+k_tmp*xt(ixt,il,2))/(rr(il,1)+dqreste_tmp+k_tmp*rr(il,2))
    38233820                dx_tmp=R_tmp*(rr(il,1)+dqreste_tmp+dq_tmp)-(xt(ixt,il,1)+dxreste_tmp)
    38243821                fxt(ixt,il,1)=fxt(ixt,il,1) &
    3825      &                 + dx_tmp/delt
    3826 #ifdef ISOVERIF
    3827                 if (ixt.eq.iso_HDO) then
    3828                 write(*,*) 'cv30_routines 3888: il=',il
    3829                 write(*,*) 'dq_tmp,rr(il,1)=',dq_tmp,rr(il,1)
    3830                 write(*,*) 'R_tmp,dx_tmp,delt=',R_tmp,dx_tmp,delt
    3831                 write(*,*) 'xt(ixt,il,1:2)=',xt(ixt,il,1:2)
    3832                 write(*,*) 'rr(il,1:2)=',rr(il,1:2)
    3833                 write(*,*) 'fxt=',dx_tmp/delt
    3834                 write(*,*) 'rr(il,1)+dq_tmp=',rr(il,1)+dq_tmp
    3835                 write(*,*) 'xt(ixt,il,1)+dx_tmp=',xt(ixt,il,1)+dx_tmp
    3836                 write(*,*) 'xt(ixt,il,1)+fxt(ixt,il,1)*delt=', &
    3837      &                   xt(ixt,il,1)+fxt(ixt,il,1)*delt
    3838                 write(*,*) 'dqreste_tmp,dxreste_tmp=',dqreste_tmp,dxreste_tmp
    3839                 write(*,*) 'formule classique: fxt_Am=',0.01*grav*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
    3840                 write(*,*) 'donnerait dxt=',0.01*grav*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)*delt
    3841                 endif !if (ixt.eq.iso_HDO) then
     3822                       + dx_tmp/delt
     3823#ifdef ISOVERIF
     3824                IF (ixt.EQ.iso_HDO) THEN
     3825                WRITE(*,*) 'cv30_routines 3888: il=',il
     3826                WRITE(*,*) 'dq_tmp,rr(il,1)=',dq_tmp,rr(il,1)
     3827                WRITE(*,*) 'R_tmp,dx_tmp,delt=',R_tmp,dx_tmp,delt
     3828                WRITE(*,*) 'xt(ixt,il,1:2)=',xt(ixt,il,1:2)
     3829                WRITE(*,*) 'rr(il,1:2)=',rr(il,1:2)
     3830                WRITE(*,*) 'fxt=',dx_tmp/delt
     3831                WRITE(*,*) 'rr(il,1)+dq_tmp=',rr(il,1)+dq_tmp
     3832                WRITE(*,*) 'xt(ixt,il,1)+dx_tmp=',xt(ixt,il,1)+dx_tmp
     3833                WRITE(*,*) 'xt(ixt,il,1)+fxt(ixt,il,1)*delt=', &
     3834                         xt(ixt,il,1)+fxt(ixt,il,1)*delt
     3835                WRITE(*,*) 'dqreste_tmp,dxreste_tmp=',dqreste_tmp,dxreste_tmp
     3836                WRITE(*,*) 'formule classique: fxt_Am=',0.01*grav*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
     3837                WRITE(*,*) 'donnerait dxt=',0.01*grav*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)*delt
     3838                endif !if (ixt.EQ.iso_HDO) THEN
    38423839#endif
    38433840#ifdef DIAGISO
    3844                 if (ixt.le.niso) then
     3841                IF (ixt.le.niso) THEN
    38453842                        fxt_fluxmasse(ixt,il,1)=fxt_fluxmasse(ixt,il,1) &
    3846      &                 + dx_tmp/delt
     3843                       + dx_tmp/delt
    38473844                endif
    38483845#endif
    38493846           enddo ! do ixt = 1, ntraciso
    3850         else !if (dq_tmp/rr(il,1).lt.-0.9) then
     3847        else !if (dq_tmp/rr(il,1).lt.-0.9) THEN
    38513848                ! formulation habituelle qui avait toujours marche de 2006 a
    38523849                ! decembre 2017.
    3853            do ixt = 1, ntraciso     
     3850           DO ixt = 1, ntraciso
    38543851                fxt(ixt,il,1)=fxt(ixt,il,1) &
    3855      &       +0.01*grav*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
     3852             +0.01*grav*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
    38563853#ifdef DIAGISO
    3857                 if (ixt.le.niso) then
     3854                IF (ixt.le.niso) THEN
    38583855                fxt_fluxmasse(ixt,il,1)=fxt_fluxmasse(ixt,il,1) &
    3859      &      +0.01*grav*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
     3856            +0.01*grav*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
    38603857                endif
    38613858#endif
    38623859           enddo !do ixt = 1, ntraciso
    3863         endif !if (dq_tmp/rr(il,1).lt.-0.9) then
    3864 
     3860        endif !if (dq_tmp/rr(il,1).lt.-0.9) THEN
    38653861       ! cam verif
    38663862#ifdef ISOVERIF
    3867           if (iso_eau.gt.0) then
    3868               call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
    3869      &           fr(il,1),'cv30_routines 3251', &
    3870      &           errmax,errmaxrel)
    3871           endif !if (iso_eau.gt.0) then
    3872           !write(*,*) 'il,am(il)=',il,am(il)
    3873           if ((iso_HDO.gt.0).and. &
    3874      &           (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
    3875             if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,1) &
    3876      &        +delt*fxt(iso_HDO,il,1))/(rr(il,1)+delt*fr(il,1)), &
    3877      &           'cv30_yield 3125, ddft en 1').eq.1) then
    3878                 write(*,*) 'il,rr(il,1),delt=',il,rr(il,1),delt
    3879                 write(*,*) 'deltaDxt=',deltaD(xt(iso_HDO,il,1)/rr(il,1))
    3880                 write(*,*) 'delt*fr(il,1),fr(il,1)=',delt*fr(il,1),fr(il,1)
    3881                 write(*,*) 'fxt=',fxt(iso_HDO,il,1)
    3882                 write(*,*) 'fq_ddft(il,1)=',0.01*grav*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
    3883                 write(*,*) 'fq_evapprecip(il,1)=',sigd*0.5*(evap(il,1)+evap(il,2))
    3884                 write(*,*) 'fq_fluxmasse(il,1)=', 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
    3885                 write(*,*) 'deltaDfq_ddft=',deltaD((xtp(iso_HDO,il,2)-xt(iso_HDO,il,1))/(rp(il,2)-rr(il,1)))
    3886                 write(*,*) 'deltaDfq_evapprecip=',deltaD((xtevap(iso_HDO,il,1)+xtevap(iso_HDO,il,2))/(evap(il,1)+evap(il,2)))
    3887                 write(*,*) 'deltaDfq_fluxmasse=',deltaD((xt(iso_HDO,il,2)-xt(iso_HDO,il,1))/(rr(il,2)-rr(il,1)))
    3888                 write(*,*) 'rr(il,2),rr(il,1)=',rr(il,2),rr(il,1)
    3889                 write(*,*) 'xt(iso_HDO,il,2),xt(iso_HDO,il,1)',xt(iso_HDO,il,2),xt(iso_HDO,il,1)
    3890                 write(*,*) 'dq_tmp=',dq_tmp
    3891                 call abort_physic('cv30_routines','cv30_yield',1)
     3863          IF (iso_eau.gt.0) THEN
     3864              CALL iso_verif_egalite_choix(fxt(iso_eau,il,1), &
     3865                 fr(il,1),'cv30_routines 3251', &
     3866                 errmax,errmaxrel)
     3867          endif !if (iso_eau.gt.0) THEN
     3868          !WRITE(*,*) 'il,am(il)=',il,am(il)
     3869          IF ((iso_HDO.gt.0).AND. &
     3870                 (rr(il,1)+delt*fr(il,1).gt.ridicule)) THEN
     3871            IF (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,1) &
     3872              +delt*fxt(iso_HDO,il,1))/(rr(il,1)+delt*fr(il,1)), &
     3873                 'cv30_yield 3125, ddft en 1').EQ.1) THEN
     3874                WRITE(*,*) 'il,rr(il,1),delt=',il,rr(il,1),delt
     3875                WRITE(*,*) 'deltaDxt=',deltaD(xt(iso_HDO,il,1)/rr(il,1))
     3876                WRITE(*,*) 'delt*fr(il,1),fr(il,1)=',delt*fr(il,1),fr(il,1)
     3877                WRITE(*,*) 'fxt=',fxt(iso_HDO,il,1)
     3878                WRITE(*,*) 'fq_ddft(il,1)=',0.01*grav*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
     3879                WRITE(*,*) 'fq_evapprecip(il,1)=',sigd*0.5*(evap(il,1)+evap(il,2))
     3880                WRITE(*,*) 'fq_fluxmasse(il,1)=', 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
     3881                WRITE(*,*) 'deltaDfq_ddft=',deltaD((xtp(iso_HDO,il,2)-xt(iso_HDO,il,1))/(rp(il,2)-rr(il,1)))
     3882                WRITE(*,*) 'deltaDfq_evapprecip=',deltaD((xtevap(iso_HDO,il,1)+xtevap(iso_HDO,il,2))/(evap(il,1)+evap(il,2)))
     3883                WRITE(*,*) 'deltaDfq_fluxmasse=',deltaD((xt(iso_HDO,il,2)-xt(iso_HDO,il,1))/(rr(il,2)-rr(il,1)))
     3884                WRITE(*,*) 'rr(il,2),rr(il,1)=',rr(il,2),rr(il,1)
     3885                WRITE(*,*) 'xt(iso_HDO,il,2),xt(iso_HDO,il,1)',xt(iso_HDO,il,2),xt(iso_HDO,il,1)
     3886                WRITE(*,*) 'dq_tmp=',dq_tmp
     3887                CALL abort_physic('cv30_routines','cv30_yield',1)
    38923888            endif ! iso_verif_aberrant_enc_nostop
    3893           endif !if (iso_HDO.gt.0) then
     3889          endif !if (iso_HDO.gt.0) THEN
    38943890#ifdef ISOTRAC
    3895         call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3417')
    3896         do ixt=1,ntraciso
     3891        CALL iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3417')
     3892        DO ixt=1,ntraciso
    38973893          xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
    38983894        enddo
    3899         if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3395',1e-5) &
    3900      &           .eq.1) then
    3901               write(*,*) 'il=',il 
    3902               write(*,*) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
    3903               write(*,*) 'xt(:,il,1)=' ,xt(:,il,1)
     3895        IF (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3395',1e-5) &
     3896                 .EQ.1) THEN
     3897              WRITE(*,*) 'il=',il
     3898              WRITE(*,*) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
     3899              WRITE(*,*) 'xt(:,il,1)=' ,xt(:,il,1)
    39043900#ifdef DIAGISO
    3905               write(*,*) 'fxt_fluxmasse(:,il,1)=',fxt_fluxmasse(:,il,1)
    3906               write(*,*) 'fxt_ddft(:,il,1)=',fxt_ddft(:,il,1)
    3907               write(*,*) 'fxt_evapprecip(:,il,1)=', &
    3908      &                   fxt_evapprecip(:,il,1)
    3909               write(*,*) 'xt(:,il,2)=',xt(:,il,2)
    3910               write(*,*) 'xtp(:,il,2)=',xtp(:,il,2)
    3911               write(*,*) 'xtevap(:,il,1)=',xtevap(:,il,1)
    3912               write(*,*) 'xtevap(:,il,2)=',xtevap(:,il,2)
    3913               write(*,*) 'facam,facmp,facev=',0.01*grav*am(il)*work(il), &
    3914      &          0.01*grav*mp(il,2)*work(il),sigd*0.5
    3915 #endif                           
     3901              WRITE(*,*) 'fxt_fluxmasse(:,il,1)=',fxt_fluxmasse(:,il,1)
     3902              WRITE(*,*) 'fxt_ddft(:,il,1)=',fxt_ddft(:,il,1)
     3903              WRITE(*,*) 'fxt_evapprecip(:,il,1)=', &
     3904                         fxt_evapprecip(:,il,1)
     3905              WRITE(*,*) 'xt(:,il,2)=',xt(:,il,2)
     3906              WRITE(*,*) 'xtp(:,il,2)=',xtp(:,il,2)
     3907              WRITE(*,*) 'xtevap(:,il,1)=',xtevap(:,il,1)
     3908              WRITE(*,*) 'xtevap(:,il,2)=',xtevap(:,il,2)
     3909              WRITE(*,*) 'facam,facmp,facev=',0.01*grav*am(il)*work(il), &
     3910                0.01*grav*mp(il,2)*work(il),sigd*0.5
     3911#endif
    39163912!              stop
    39173913        endif
    3918 #endif           
     3914#endif
    39193915#endif
    39203916       ! end cam verif
    … …  
    39323928
    39333929#ifdef ISO
    3934        do ixt = 1, ntraciso
     3930       DO ixt = 1, ntraciso
    39353931       fxt(ixt,il,1)=0.1*mp(il,2)*(xtp(ixt,il,2)-xt(ixt,il,1))*work(il) &
    3936      &          +sigd*0.5*(xtevap(ixt,il,1)+xtevap(ixt,il,2))
     3932                +sigd*0.5*(xtevap(ixt,il,1)+xtevap(ixt,il,2))
    39373933       fxt(ixt,il,1)=fxt(ixt,il,1) &
    3938      &          +0.1*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
     3934                +0.1*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
    39393935       enddo
    39403936
    39413937#ifdef DIAGISO
    39423938       fq_ddft(il,1)=fq_ddft(il,1) &
    3943      &          +0.1*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
     3939                +0.1*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
    39443940       fq_evapprecip(il,1)=fq_evapprecip(il,1)   &
    3945      &          +sigd*0.5*(evap(il,1)+evap(il,2))
     3941                +sigd*0.5*(evap(il,1)+evap(il,2))
    39463942       fq_fluxmasse(il,1)=fq_fluxmasse(il,1) &
    3947      &           +0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
    3948        do ixt = 1, niso
     3943                 +0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
     3944       DO ixt = 1, niso
    39493945        fxt_fluxmasse(ixt,il,1)=fxt(ixt,il,1) &
    3950      &          +0.1*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
     3946                +0.1*am(il)*(xt(ixt,il,2)-xt(ixt,il,1))*work(il)
    39513947        fxt_ddft(ixt,il,1)=fxt(ixt,il,1) &
    3952      &           +0.1*mp(il,2)*(xtp(ixt,il,2)-xt(ixt,il,1))*work(il)
     3948                 +0.1*mp(il,2)*(xtp(ixt,il,2)-xt(ixt,il,1))*work(il)
    39533949        fxt_evapprecip(ixt,il,1)=fxt(ixt,il,1) &
    3954      &          +sigd*0.5*(xtevap(ixt,il,1)+xtevap(ixt,il,2))
     3950                +sigd*0.5*(xtevap(ixt,il,1)+xtevap(ixt,il,2))
    39553951       enddo
    39563952#endif
    3957        
    3958        
     3953
     3954
    39593955       ! cam verif
    3960 #ifdef ISOVERIF         
    3961          if (iso_eau.gt.0) then
    3962               call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
    3963      &           fr(il,1),'cv30_routines 3023', &
    3964      &           errmax,errmaxrel)
    3965           endif !if (iso_eau.gt.0) then
    3966           if ((iso_HDO.gt.0).and. &
    3967      &           (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
    3968            call iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
    3969      &           +delt*fxt(iso_HDO,il,1)) &
    3970      &           /(rr(il,1)+delt*fr(il,1)), &
    3971      &           'cv30_yield 3125b, ddft en 1')
    3972           endif !if (iso_HDO.gt.0) then
     3956#ifdef ISOVERIF
     3957         IF (iso_eau.gt.0) THEN
     3958              CALL iso_verif_egalite_choix(fxt(iso_eau,il,1), &
     3959                 fr(il,1),'cv30_routines 3023', &
     3960                 errmax,errmaxrel)
     3961          endif !if (iso_eau.gt.0) THEN
     3962          IF ((iso_HDO.gt.0).AND. &
     3963                 (rr(il,1)+delt*fr(il,1).gt.ridicule)) THEN
     3964           CALL iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
     3965                 +delt*fxt(iso_HDO,il,1)) &
     3966                 /(rr(il,1)+delt*fr(il,1)), &
     3967                 'cv30_yield 3125b, ddft en 1')
     3968          endif !if (iso_HDO.gt.0) THEN
    39733969#ifdef ISOTRAC
    3974         call iso_verif_traceur_justmass(fxt(1,il,1), &
    3975      &           'cv30_routine 3417')
    3976         do ixt=1,ntraciso
     3970        CALL iso_verif_traceur_justmass(fxt(1,il,1), &
     3971                 'cv30_routine 3417')
     3972        DO ixt=1,ntraciso
    39773973          xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
    39783974        enddo
    3979         if (iso_verif_tracpos_choix_nostop(xtnew, &
    3980      &           'cv30_yield 3449',1e-5) &
    3981      &           .eq.1) then
    3982               write(*,*) 'il=',il   
    3983               write(*,*) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
    3984               write(*,*) 'xt(:,il,1)=' ,xt(:,il,1)
     3975        IF (iso_verif_tracpos_choix_nostop(xtnew, &
     3976                 'cv30_yield 3449',1e-5) &
     3977                 .EQ.1) THEN
     3978              WRITE(*,*) 'il=',il
     3979              WRITE(*,*) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
     3980              WRITE(*,*) 'xt(:,il,1)=' ,xt(:,il,1)
    39853981!              stop
    39863982        endif
    3987 #endif           
     3983#endif
    39883984#endif
    39893985       ! end cam verif
    … …  
    39993995  ! do j=1,ntra
    40003996  ! do il=1,ncum
    4001   ! if (cvflag_grav) then
     3997  ! if (cvflag_grav) THEN
    40023998  ! ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
    40033999  ! :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
    … …  
    40074003  ! :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
    40084004  ! :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
    4009   ! endif
     4005  ! END IF
    40104006  ! enddo
    40114007  ! enddo
    … …  
    40234019
    40244020#ifdef ISO
    4025        do ixt = 1, ntraciso
     4021       DO ixt = 1, ntraciso
    40264022       fxt(ixt,il,1)=fxt(ixt,il,1) &
    4027      &          +0.01*grav*work(il)*ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
     4023                +0.01*grav*work(il)*ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
    40284024       enddo
    40294025
    40304026#ifdef DIAGISO
    40314027        fq_detrainement(il,1)=fq_detrainement(il,1) &
    4032      &       +0.01*grav*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
     4028             +0.01*grav*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
    40334029        f_detrainement(il,1)=f_detrainement(il,1) &
    4034      &          +0.01*grav*work(il)*ment(il,j,1)
     4030                +0.01*grav*work(il)*ment(il,j,1)
    40354031        q_detrainement(il,1)=q_detrainement(il,1) &
    4036      &          +0.01*grav*work(il)*ment(il,j,1)*qent(il,j,1)
    4037         do ixt = 1, niso
     4032                +0.01*grav*work(il)*ment(il,j,1)*qent(il,j,1)
     4033        DO ixt = 1, niso
    40384034          fxt_detrainement(ixt,il,1)=fxt_detrainement(ixt,il,1) &
    4039      &          +0.01*grav*work(il)*ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
     4035                +0.01*grav*work(il)*ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
    40404036          xt_detrainement(ixt,il,1)=xt_detrainement(ixt,il,1) &
    4041      &          +0.01*grav*work(il)*ment(il,j,1)*xtent(ixt,il,j,1)
     4037                +0.01*grav*work(il)*ment(il,j,1)*xtent(ixt,il,j,1)
    40424038        enddo
    40434039#endif
    … …  
    40454041       ! cam verif
    40464042#ifdef ISOVERIF
    4047           if (iso_eau.gt.0) then
    4048               call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
    4049      &           fr(il,1),'cv30_routines 3251',errmax,errmaxrel)
    4050           endif !if (iso_eau.gt.0) then
    4051           if ((iso_HDO.gt.0).and. &
    4052      &           (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
    4053            call iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
    4054      &         +delt*fxt(iso_HDO,il,1))/(rr(il,1)+delt*fr(il,1)), &
    4055      &         'cv30_yield 3127, dtr melanges')
    4056           endif !if (iso_HDO.gt.0) then
     4043          IF (iso_eau.gt.0) THEN
     4044              CALL iso_verif_egalite_choix(fxt(iso_eau,il,1), &
     4045                 fr(il,1),'cv30_routines 3251',errmax,errmaxrel)
     4046          endif !if (iso_eau.gt.0) THEN
     4047          IF ((iso_HDO.gt.0).AND. &
     4048                 (rr(il,1)+delt*fr(il,1).gt.ridicule)) THEN
     4049           CALL iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
     4050               +delt*fxt(iso_HDO,il,1))/(rr(il,1)+delt*fr(il,1)), &
     4051               'cv30_yield 3127, dtr melanges')
     4052          endif !if (iso_HDO.gt.0) THEN
    40574053#ifdef ISOTRAC
    4058         call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3417')
    4059         do ixt=1,ntraciso
     4054        CALL iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3417')
     4055        DO ixt=1,ntraciso
    40604056          xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
    40614057        enddo
    4062         if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3525',1e-5) &
    4063      &           .eq.1) then
    4064               write(*,*) 'il=',il   
    4065               write(*,*) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
    4066               write(*,*) 'fac=', 0.01*grav*work(il)*ment(il,j,1)
    4067               write(*,*) 'xt(:,il,1)=' ,xt(:,il,1)
    4068               write(*,*) 'xtent(:,il,j,1)=' ,xtent(:,il,j,1)
     4058        IF (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3525',1e-5) &
     4059                 .EQ.1) THEN
     4060              WRITE(*,*) 'il=',il
     4061              WRITE(*,*) 'delt,fxt(:,il,1)=',delt,fxt(:,il,1)
     4062              WRITE(*,*) 'fac=', 0.01*grav*work(il)*ment(il,j,1)
     4063              WRITE(*,*) 'xt(:,il,1)=' ,xt(:,il,1)
     4064              WRITE(*,*) 'xtent(:,il,j,1)=' ,xtent(:,il,j,1)
    40694065!              stop
    40704066        endif
    4071 #endif           
     4067#endif
    40724068#endif
    40734069       ! end cam verif
    … …  
    40834079
    40844080#ifdef ISO
    4085        do ixt = 1, ntraciso
     4081       DO ixt = 1, ntraciso
    40864082       fxt(ixt,il,1)=fxt(ixt,il,1) &
    4087      & +0.1*work(il)*ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
     4083       +0.1*work(il)*ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
    40884084       enddo
    40894085
    40904086#ifdef DIAGISO
    40914087        fq_detrainement(il,1)=fq_detrainement(il,1) &
    4092      &         +0.1*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
     4088               +0.1*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
    40934089        f_detrainement(il,1)=f_detrainement(il,1) &
    4094      &         +0.1*work(il)*ment(il,j,1)
     4090               +0.1*work(il)*ment(il,j,1)
    40954091        q_detrainement(il,1)=q_detrainement(il,1) &
    4096      &         +0.1*work(il)*ment(il,j,1)*qent(il,j,1)
    4097         do ixt = 1, niso
     4092               +0.1*work(il)*ment(il,j,1)*qent(il,j,1)
     4093        DO ixt = 1, niso
    40984094          fxt_detrainement(ixt,il,1)=fxt_detrainement(ixt,il,1) &
    4099      &          +0.1*work(il)*ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
     4095                +0.1*work(il)*ment(il,j,1)*(xtent(ixt,il,j,1)-xt(ixt,il,1))
    41004096                xt_detrainement(ixt,il,1)=xt_detrainement(ixt,il,1) &
    4101      &          +0.1*work(il)*ment(il,j,1)*xtent(ixt,il,j,1)
     4097                +0.1*work(il)*ment(il,j,1)*xtent(ixt,il,j,1)
    41024098        enddo
    41034099#endif
    … …  
    41054101       ! cam verif
    41064102#ifdef ISOVERIF
    4107           if (iso_eau.gt.0) then
    4108               call iso_verif_egalite_choix(fxt(iso_eau,il,1), &
    4109      &           fr(il,1),'cv30_routines 3092',errmax,errmaxrel)
    4110           endif !if (iso_eau.gt.0) then
    4111           if ((iso_HDO.gt.0).and. &
    4112      &           (rr(il,1)+delt*fr(il,1).gt.ridicule)) then
    4113            call iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
    4114      &        +delt*fxt(iso_HDO,il,1))/(rr(il,1)+delt*fr(il,1)), &
    4115      &        'cv30_yield 3127b, dtr melanges')
    4116           endif !if (iso_HDO.gt.0) then
     4103          IF (iso_eau.gt.0) THEN
     4104              CALL iso_verif_egalite_choix(fxt(iso_eau,il,1), &
     4105                 fr(il,1),'cv30_routines 3092',errmax,errmaxrel)
     4106          endif !if (iso_eau.gt.0) THEN
     4107          IF ((iso_HDO.gt.0).AND. &
     4108                 (rr(il,1)+delt*fr(il,1).gt.ridicule)) THEN
     4109           CALL iso_verif_aberrant_encadre((xt(iso_HDO,il,1) &
     4110              +delt*fxt(iso_HDO,il,1))/(rr(il,1)+delt*fr(il,1)), &
     4111              'cv30_yield 3127b, dtr melanges')
     4112          endif !if (iso_HDO.gt.0) THEN
    41174113#ifdef ISOTRAC
    4118         call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3462')
    4119         do ixt=1,ntraciso
     4114        CALL iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3462')
     4115        DO ixt=1,ntraciso
    41204116          xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
    41214117        enddo
    4122         if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3753',1e-5) &
    4123      &           .eq.1) then
    4124               write(*,*) 'il=',il   
     4118        IF (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3753',1e-5) &
     4119                 .EQ.1) THEN
     4120              WRITE(*,*) 'il=',il
    41254121        endif
    4126 #endif           
     4122#endif
    41274123#endif
    41284124       ! end cam verif
    … …  
    41374133  ! do j=2,nl
    41384134  ! do il=1,ncum
    4139   ! if (j.le.inb(il)) then
    4140 
    4141   ! if (cvflag_grav) then
     4135  ! if (j.le.inb(il)) THEN
     4136  ! if (cvflag_grav) THEN
    41424137  ! ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
    41434138  ! :                *(traent(il,j,1,k)-tra(il,1,k))
    … …  
    41454140  ! ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
    41464141  ! :                *(traent(il,j,1,k)-tra(il,1,k))
    4147   ! endif
    4148 
    4149   ! endif
     4142  ! END IF
     4143
     4144  ! END IF
    41504145  ! enddo
    41514146  ! enddo
    … …  
    42484243#ifdef DIAGISO
    42494244        fq_fluxmasse(il,i)=fq_fluxmasse(il,i) &
    4250      &           +0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i)) &
    4251      &           -ad(il)*(rr(il,i)-rr(il,i-1)))
     4245                 +0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i)) &
     4246                 -ad(il)*(rr(il,i)-rr(il,i-1)))
    42524247        ! modif 2 fev: pour avoir subsidence compensatoire totale, on retranche
    42534248        ! ad.
    … …  
    42604255       ! meme temps.
    42614256       dq_tmp= 0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i)) &
    4262     &            -ad(il)*(rr(il,i)-rr(il,i-1)))*delt
     4257                 -ad(il)*(rr(il,i)-rr(il,i-1)))*delt
    42634258       ! c'est equivalent a dqi= kamp1*qip1+kad*qim1-(kamp1+kad)*qi
    4264        if ((dq_tmp/rr(il,i).lt.-0.9).and.correction_excess_aberrant) then
     4259       IF ((dq_tmp/rr(il,i).lt.-0.9).AND.correction_excess_aberrant) THEN
    42654260        ! nouvelle formulation
    42664261        k_tmp=0.01*grav*dpinv*amp1(il)*delt
    42674262        kad_tmp=0.01*grav*dpinv*ad(il)*delt
    4268         do ixt = 1, ntraciso
     4263        DO ixt = 1, ntraciso
    42694264            R_tmp=(xt(ixt,il,i)+k_tmp*xt(ixt,il,i+1)+kad_tmp*xt(ixt,il,i-1)) &
    4270                 & /(rr(il,i)+k_tmp*rr(il,i+1)+kad_tmp*rr(il,i-1))
     4265                  /(rr(il,i)+k_tmp*rr(il,i+1)+kad_tmp*rr(il,i-1))
    42714266            dx_tmp=  R_tmp*( rr(il,i)+ dq_tmp)-xt(ixt,il,i)
    42724267            fxt(ixt,il,i)= dx_tmp/delt
    42734268#ifdef ISOVERIF
    4274                 if ((ixt.eq.iso_HDO).or.(ixt.eq.iso_eau)) then
    4275                 write(*,*) 'cv30_routines 4367: il,i,ixt=',il,i,ixt
    4276                 write(*,*) 'dq_tmp,rr(il,i)=',dq_tmp,rr(il,i)
    4277                 write(*,*) 'R_tmp,dx_tmp,delt=',R_tmp,dx_tmp,delt
    4278                 write(*,*) 'amp1(il),ad(il)=',amp1(il),ad(il)
    4279                 write(*,*) 'xt(ixt,il,i-1:i+1)=',xt(ixt,il,i-1:i+1)
    4280                 write(*,*) 'rr(il,i-1:i+1)=',rr(il,i-1:i+1)
    4281                 write(*,*) 'fxt=',dx_tmp/delt
    4282                 write(*,*) 'rr(il,i)+dq_tmp=',rr(il,1)+dq_tmp
    4283                 write(*,*) 'xt(ixt,il,i)+dx_tmp=',xt(ixt,il,i)+dx_tmp
    4284                 write(*,*) 'xt(ixt,il,i)+fxt(ixt,il,i)*delt=', &
    4285      &                   xt(ixt,il,i)+fxt(ixt,il,i)*delt
    4286                 write(*,*) 'fxt(:,il,i)=',fxt(:,il,i)
    4287                 endif !if (ixt.eq.iso_HDO) then 
    4288 #endif 
    4289         enddo ! do ixt = 1, ntraciso 
     4269                IF ((ixt.EQ.iso_HDO).OR.(ixt.EQ.iso_eau)) THEN
     4270                WRITE(*,*) 'cv30_routines 4367: il,i,ixt=',il,i,ixt
     4271                WRITE(*,*) 'dq_tmp,rr(il,i)=',dq_tmp,rr(il,i)
     4272                WRITE(*,*) 'R_tmp,dx_tmp,delt=',R_tmp,dx_tmp,delt
     4273                WRITE(*,*) 'amp1(il),ad(il)=',amp1(il),ad(il)
     4274                WRITE(*,*) 'xt(ixt,il,i-1:i+1)=',xt(ixt,il,i-1:i+1)
     4275                WRITE(*,*) 'rr(il,i-1:i+1)=',rr(il,i-1:i+1)
     4276                WRITE(*,*) 'fxt=',dx_tmp/delt
     4277                WRITE(*,*) 'rr(il,i)+dq_tmp=',rr(il,1)+dq_tmp
     4278                WRITE(*,*) 'xt(ixt,il,i)+dx_tmp=',xt(ixt,il,i)+dx_tmp
     4279                WRITE(*,*) 'xt(ixt,il,i)+fxt(ixt,il,i)*delt=', &
     4280                         xt(ixt,il,i)+fxt(ixt,il,i)*delt
     4281                WRITE(*,*) 'fxt(:,il,i)=',fxt(:,il,i)
     4282                endif !if (ixt.EQ.iso_HDO) THEN
     4283#endif
     4284        enddo ! do ixt = 1, ntraciso
    42904285#ifdef DIAGISO
    4291         do ixt = 1, niso
     4286        DO ixt = 1, niso
    42924287                fxt_fluxmasse(ixt,il,i)=fxt(ixt,il,i)
    42934288        enddo
    4294 #endif 
    4295        else !if (dq_tmp/rr(il,i).lt.-0.9) then
     4289#endif
     4290       else !if (dq_tmp/rr(il,i).lt.-0.9) THEN
    42964291        ! ancienne formulation
    4297          do ixt = 1, ntraciso
     4292         DO ixt = 1, ntraciso
    42984293         fxt(ixt,il,i)= &
    4299      &          0.01*grav*dpinv*(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
    4300      &           -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
     4294                0.01*grav*dpinv*(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
     4295                 -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
    43014296         enddo
    43024297#ifdef DIAGISO
    4303         do ixt = 1, niso
     4298        DO ixt = 1, niso
    43044299           fxt_fluxmasse(ixt,il,i)=fxt_fluxmasse(ixt,il,i)+ &
    4305      &          0.01*grav*dpinv*(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
    4306      &           -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
     4300                0.01*grav*dpinv*(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
     4301                 -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
    43074302        enddo
    4308 #endif 
    4309        endif !if (dq_tmp/rr(il,i).lt.-0.9) then
    4310          
    4311        
     4303#endif
     4304       endif !if (dq_tmp/rr(il,i).lt.-0.9) THEN
    43124305       ! cam verif
    43134306#ifdef ISOVERIF
    4314         if (iso_eau.gt.0) then
    4315               call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
    4316      &           fr(il,i),'cv30_routines 3226',errmax,errmaxrel)
    4317         endif !if (iso_eau.gt.0) then
    4318         do ixt=1,niso
    4319             call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3229')
     4307        IF (iso_eau.gt.0) THEN
     4308              CALL iso_verif_egalite_choix(fxt(iso_eau,il,i), &
     4309                 fr(il,i),'cv30_routines 3226',errmax,errmaxrel)
     4310        endif !if (iso_eau.gt.0) THEN
     4311        DO ixt=1,niso
     4312            CALL iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3229')
    43204313        enddo
    4321         if ((iso_HDO.gt.0).and. &
    4322      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    4323          call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
    4324      &                   +delt*fxt(iso_HDO,il,i)) &
    4325      &           /(rr(il,i)+delt*fr(il,i)), &
    4326      &           'cv30_yield 3384, flux masse')
    4327         endif !if (iso_HDO.gt.0) then
    4328         if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
    4329      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    4330          call iso_verif_O18_aberrant( &
    4331      &           (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
    4332      &           (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
    4333      &           'cv30_yield 3384,O18, flux masse')
    4334         endif !if (iso_HDO.gt.0) then
     4314        IF ((iso_HDO.gt.0).AND. &
     4315                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     4316         CALL iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
     4317                         +delt*fxt(iso_HDO,il,i)) &
     4318                 /(rr(il,i)+delt*fr(il,i)), &
     4319                 'cv30_yield 3384, flux masse')
     4320        endif !if (iso_HDO.gt.0) THEN
     4321        IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0).AND. &
     4322                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     4323         CALL iso_verif_O18_aberrant( &
     4324                 (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
     4325                 (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
     4326                 'cv30_yield 3384,O18, flux masse')
     4327        endif !if (iso_HDO.gt.0) THEN
    43354328#ifdef ISOTRAC
    4336         call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3626')
    4337         do ixt=1,ntraciso
     4329        CALL iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3626')
     4330        DO ixt=1,ntraciso
    43384331          xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
    43394332        enddo
    4340         if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3727',1e-5) &
    4341      &           .eq.1) then
    4342               write(*,*) 'il,i=',il,i   
    4343               write(*,*) 'fxt(:,il,i)=',fxt(:,il,i)
    4344               write(*,*) 'amp1(il),ad(il),fac=',  &
    4345      &              amp1(il),ad(il),0.01*grav*dpinv
    4346               write(*,*) 'xt(:,il,i+1)=' ,xt(:,il,i+1)
    4347               write(*,*) 'xt(:,il,i)=' ,xt(:,il,i)
    4348               write(*,*) 'xt(:,il,i-1)=' ,xt(:,il,i-1)
     4333        IF (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3727',1e-5) &
     4334                 .EQ.1) THEN
     4335              WRITE(*,*) 'il,i=',il,i
     4336              WRITE(*,*) 'fxt(:,il,i)=',fxt(:,il,i)
     4337              WRITE(*,*) 'amp1(il),ad(il),fac=',  &
     4338                    amp1(il),ad(il),0.01*grav*dpinv
     4339              WRITE(*,*) 'xt(:,il,i+1)=' ,xt(:,il,i+1)
     4340              WRITE(*,*) 'xt(:,il,i)=' ,xt(:,il,i)
     4341              WRITE(*,*) 'xt(:,il,i-1)=' ,xt(:,il,i-1)
    43494342!              stop
    43504343        endif
    4351 #endif         
    4352 #endif
    4353        ! end cam verif 
     4344#endif
     4345#endif
     4346       ! end cam verif
    43544347#endif
    43554348        ELSE ! cvflag_grav
    … …  
    43624355
    43634356#ifdef ISO
    4364        do ixt = 1, ntraciso
     4357       DO ixt = 1, ntraciso
    43654358       fxt(ixt,il,i)= &
    4366      &   0.1*dpinv*(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
    4367      &           -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
     4359         0.1*dpinv*(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
     4360                 -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
    43684361       enddo
    43694362
    43704363#ifdef DIAGISO
    43714364        fq_fluxmasse(il,i)=fq_fluxmasse(il,i) &
    4372      &           +0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i)) &
    4373      &           -ad(il)*(rr(il,i)-rr(il,i-1)))
    4374         do ixt = 1, niso
     4365                 +0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i)) &
     4366                 -ad(il)*(rr(il,i)-rr(il,i-1)))
     4367        DO ixt = 1, niso
    43754368        fxt_fluxmasse(ixt,il,i)=fxt_fluxmasse(ixt,il,i)+ &
    4376      &   0.1*dpinv*(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
    4377      &           -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
     4369         0.1*dpinv*(amp1(il)*(xt(ixt,il,i+1)-xt(ixt,il,i)) &
     4370                 -ad(il)*(xt(ixt,il,i)-xt(ixt,il,i-1)))
    43784371        enddo
    4379 #endif     
     4372#endif
    43804373
    43814374       ! cam verif
    43824375#ifdef ISOVERIF
    4383           if (iso_eau.gt.0) then
    4384               call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
    4385      &           fr(il,i),'cv30_routines 3252',errmax,errmaxrel)
    4386           endif !if (iso_eau.gt.0) then
    4387           do ixt=1,niso
    4388             call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3229')
     4376          IF (iso_eau.gt.0) THEN
     4377              CALL iso_verif_egalite_choix(fxt(iso_eau,il,i), &
     4378                 fr(il,i),'cv30_routines 3252',errmax,errmaxrel)
     4379          endif !if (iso_eau.gt.0) THEN
     4380          DO ixt=1,niso
     4381            CALL iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3229')
    43894382          enddo
    43904383          ! correction 21 oct 2008
    4391           if ((iso_HDO.gt.0).and. &
    4392      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    4393          call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
    4394      &       +delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
    4395      &       'cv30_yield 3384b flux masse')
    4396         if (iso_O18.gt.0) then
    4397           call iso_verif_O18_aberrant( &
    4398      &           (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
    4399      &           /(rr(il,i)+delt*fr(il,i)), &
    4400      &           (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
    4401      &           /(rr(il,i)+delt*fr(il,i)), &
    4402      &           'cv30_yield 3384bO18 flux masse')
    4403         endif !if (iso_O18.gt.0) then
    4404         endif !if (iso_HDO.gt.0) then
     4384          IF ((iso_HDO.gt.0).AND. &
     4385                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     4386         CALL iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
     4387             +delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
     4388             'cv30_yield 3384b flux masse')
     4389        IF (iso_O18.gt.0) THEN
     4390          CALL iso_verif_O18_aberrant( &
     4391                 (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
     4392                 /(rr(il,i)+delt*fr(il,i)), &
     4393                 (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
     4394                 /(rr(il,i)+delt*fr(il,i)), &
     4395                 'cv30_yield 3384bO18 flux masse')
     4396        endif !if (iso_O18.gt.0) THEN
     4397        endif !if (iso_HDO.gt.0) THEN
    44054398#ifdef ISOTRAC
    4406         call iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3674')
    4407         do ixt=1,ntraciso
     4399        CALL iso_verif_traceur_justmass(fxt(1,il,1),'cv30_routine 3674')
     4400        DO ixt=1,ntraciso
    44084401          xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
    44094402        enddo
    4410         if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3775',1e-5) &
    4411      &           .eq.1) then
    4412               write(*,*) 'il,i=',il,i 
     4403        IF (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3775',1e-5) &
     4404                 .EQ.1) THEN
     4405              WRITE(*,*) 'il,i=',il,i
    44134406        endif
    4414 #endif         
    4415 #endif
    4416        ! end cam verif 
     4407#endif
     4408#endif
     4409       ! end cam verif
    44174410#endif
    44184411        END IF ! cvflag_grav
    … …  
    44234416    ! do k=1,ntra
    44244417    ! do il=1,ncum
    4425     ! if (i.le.inb(il)) then
     4418    ! if (i.le.inb(il)) THEN
    44264419    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
    44274420    ! cpinv=1.0/cpn(il,i)
    4428     ! if (cvflag_grav) then
     4421    ! if (cvflag_grav) THEN
    44294422    ! ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
    44304423    ! :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
    … …  
    44344427    ! :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
    44354428    ! :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
    4436     ! endif
    4437     ! endif
     4429    ! END IF
     4430    ! END IF
    44384431    ! enddo
    44394432    ! enddo
    … …  
    44584451        ! ce surplus a la meme compo que le elij, sans fractionnement.
    44594452        ! d'ou le nouveau traitement ci-dessous.
    4460       if (elij(il,k,i).gt.0.0) then
    4461         do ixt = 1, ntraciso
     4453      IF (elij(il,k,i).gt.0.0) THEN
     4454        DO ixt = 1, ntraciso
    44624455          xtawat(ixt)=awat*(xtelij(ixt,il,k,i)/elij(il,k,i))
    44634456!          xtawat(ixt)=amax1(xtawat(ixt),0.0) ! pas necessaire
    44644457        enddo
    4465       else !if (elij(il,k,i).gt.0.0) then
     4458      else !if (elij(il,k,i).gt.0.0) THEN
    44664459          ! normalement, si elij(il,k,i)<=0, alors awat=0
    44674460          ! on le verifie. Si c'est vrai -> xtawat=0 aussi
    44684461#ifdef ISOVERIF
    4469         call iso_verif_egalite(awat,0.0,'cv30_yield 3779')
    4470 #endif
    4471         do ixt = 1, ntraciso
     4462        CALL iso_verif_egalite(awat,0.0,'cv30_yield 3779')
     4463#endif
     4464        DO ixt = 1, ntraciso
    44724465          xtawat(ixt)=0.0
    4473         enddo       
     4466        enddo
    44744467      endif
    44754468
    44764469      ! cam verif
    44774470#ifdef ISOVERIF
    4478           if (iso_eau.gt.0) then
    4479               call iso_verif_egalite_choix(xtawat(iso_eau), &
    4480      &           awat,'cv30_routines 3301',errmax,errmaxrel)
    4481           endif !if (iso_eau.gt.0) then
     4471          IF (iso_eau.gt.0) THEN
     4472              CALL iso_verif_egalite_choix(xtawat(iso_eau), &
     4473                 awat,'cv30_routines 3301',errmax,errmaxrel)
     4474          endif !if (iso_eau.gt.0) THEN
    44824475#ifdef ISOTRAC
    4483         call iso_verif_traceur_justmass(xtawat(1),'cv30_routine 3729')
    4484 #endif           
    4485 #endif
    4486        ! end cam verif 
     4476        CALL iso_verif_traceur_justmass(xtawat(1),'cv30_routine 3729')
     4477#endif
     4478#endif
     4479       ! end cam verif
    44874480#endif
    44884481
    … …  
    44964489
    44974490#ifdef ISO
    4498       do ixt = 1, ntraciso
     4491      DO ixt = 1, ntraciso
    44994492      fxt(ixt,il,i)=fxt(ixt,il,i) &
    4500      &      +0.01*grav*dpinv*ment(il,k,i) &
    4501      &           *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))   
     4493            +0.01*grav*dpinv*ment(il,k,i) &
     4494                 *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
    45024495      enddo
    45034496
    45044497#ifdef DIAGISO
    45054498        fq_detrainement(il,i)=fq_detrainement(il,i) &
    4506      &          +0.01*grav*dpinv*ment(il,k,i) &
    4507      &          *(qent(il,k,i)-awat-rr(il,i))
    4508         f_detrainement(il,i)=f_detrainement(il,i)& 
    4509      &          +0.01*grav*dpinv*ment(il,k,i)
     4499                +0.01*grav*dpinv*ment(il,k,i) &
     4500                *(qent(il,k,i)-awat-rr(il,i))
     4501        f_detrainement(il,i)=f_detrainement(il,i)&
     4502                +0.01*grav*dpinv*ment(il,k,i)
    45104503        q_detrainement(il,i)=q_detrainement(il,i) &
    4511      &          +0.01*grav*dpinv*ment(il,k,i)*qent(il,k,i)
    4512         do ixt = 1, niso
     4504                +0.01*grav*dpinv*ment(il,k,i)*qent(il,k,i)
     4505        DO ixt = 1, niso
    45134506        fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
    4514      &          +0.01*grav*dpinv*ment(il,k,i) &
    4515      &           *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
     4507                +0.01*grav*dpinv*ment(il,k,i) &
     4508                 *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
    45164509        xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
    4517      &      +0.01*grav*dpinv*ment(il,k,i)*xtent(ixt,il,k,i)
     4510            +0.01*grav*dpinv*ment(il,k,i)*xtent(ixt,il,k,i)
    45184511        enddo
    4519 #endif 
     4512#endif
    45204513      ! cam verif
    45214514#ifdef ISOVERIF
    4522         if (iso_eau.gt.0) then
    4523               call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
    4524      &           fr(il,i),'cv30_routines 3325',errmax,errmaxrel)
    4525         endif !if (iso_eau.gt.0) then
    4526         do ixt=1,niso
    4527             call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3328')
     4515        IF (iso_eau.gt.0) THEN
     4516              CALL iso_verif_egalite_choix(fxt(iso_eau,il,i), &
     4517                 fr(il,i),'cv30_routines 3325',errmax,errmaxrel)
     4518        endif !if (iso_eau.gt.0) THEN
     4519        DO ixt=1,niso
     4520            CALL iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3328')
    45284521        enddo
    4529         if ((iso_HDO.gt.0).and. &
    4530      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    4531         if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
    4532      &           +delt*fxt(iso_HDO,il,i)) &
    4533      &           /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3396a, dtr mels') &
    4534      &           .eq.1) then
    4535            write(*,*) 'il,k,i=',il,k,i
    4536            write(*,*) 'rr,delt,fr=',rr(il,i),delt,fr(il,i)
    4537            write(*,*) 'frnew=',0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-awat-rr(il,i))
    4538            write(*,*) 'frold=',fr(il,i)-0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-awat-rr(il,i))
    4539            write(*,*) 'deltaDfrnew=',deltaD((xtent(iso_HDO,il,k,i)-xtawat(iso_HDO)-xt(iso_HDO,il,i)) &
     4522        IF ((iso_HDO.gt.0).AND. &
     4523                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     4524        IF (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
     4525                 +delt*fxt(iso_HDO,il,i)) &
     4526                 /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3396a, dtr mels') &
     4527                 .EQ.1) THEN
     4528           WRITE(*,*) 'il,k,i=',il,k,i
     4529           WRITE(*,*) 'rr,delt,fr=',rr(il,i),delt,fr(il,i)
     4530           WRITE(*,*) 'frnew=',0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-awat-rr(il,i))
     4531           WRITE(*,*) 'frold=',fr(il,i)-0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-awat-rr(il,i))
     4532           WRITE(*,*) 'deltaDfrnew=',deltaD((xtent(iso_HDO,il,k,i)-xtawat(iso_HDO)-xt(iso_HDO,il,i)) &
    45404533                /(qent(il,k,i)-awat-rr(il,i)))
    4541            write(*,*) 'deltaDfrold=',deltaD((fxt(iso_HDO,il,i) &
     4534           WRITE(*,*) 'deltaDfrold=',deltaD((fxt(iso_HDO,il,i) &
    45424535                -0.01*grav*dpinv*ment(il, k, i)*(xtent(iso_HDO,il,k,i)-xtawat(iso_HDO)-xt(iso_HDO,il,i))) &
    45434536                /(fr(il,i)-0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-awat-rr(il,i))))
    4544            write(*,*) 'q+=',rr(il,i)+delt*fr(il,i)
    4545            write(*,*) 'qent,awat=',qent(il,k,i),awat
    4546            write(*,*) 'elij,clw,ep=',elij(il,k,i),clw(il,i),ep(il,i)
    4547            write(*,*) 'deltaDfr=',deltaD(fxt(iso_hdo,il,i)/fr(il,i))
    4548            write(*,*) 'deltaDrr=',deltaD(xt(iso_hdo,il,i)/rr(il,i))
    4549            write(*,*) 'deltaDqent=',deltaD(xtent(iso_hdo,il,k,i) &
    4550      &                  /qent(il,k,i))
    4551            write(*,*) 'deltaDqent-awat=',deltaD((xtent(iso_hdo,il,k,i)-xtawat(iso_HDO)) &
    4552      &                  /(qent(il,k,i)-awat))
    4553            write(*,*) 'deltaDawat=',deltaD(xtawat(iso_hdo)/awat)
    4554            write(*,*) 'deltaDclw=',deltaD(xtclw(iso_hdo,il,i)/clw(il,i))         
     4537           WRITE(*,*) 'q+=',rr(il,i)+delt*fr(il,i)
     4538           WRITE(*,*) 'qent,awat=',qent(il,k,i),awat
     4539           WRITE(*,*) 'elij,clw,ep=',elij(il,k,i),clw(il,i),ep(il,i)
     4540           WRITE(*,*) 'deltaDfr=',deltaD(fxt(iso_hdo,il,i)/fr(il,i))
     4541           WRITE(*,*) 'deltaDrr=',deltaD(xt(iso_hdo,il,i)/rr(il,i))
     4542           WRITE(*,*) 'deltaDqent=',deltaD(xtent(iso_hdo,il,k,i) &
     4543                        /qent(il,k,i))
     4544           WRITE(*,*) 'deltaDqent-awat=',deltaD((xtent(iso_hdo,il,k,i)-xtawat(iso_HDO)) &
     4545                        /(qent(il,k,i)-awat))
     4546           WRITE(*,*) 'deltaDawat=',deltaD(xtawat(iso_hdo)/awat)
     4547           WRITE(*,*) 'deltaDclw=',deltaD(xtclw(iso_hdo,il,i)/clw(il,i))
    45554548!           stop
    45564549        endif
    4557         if (iso_O18.gt.0) then
    4558           call iso_verif_O18_aberrant( &
    4559      &           (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
    4560      &           /(rr(il,i)+delt*fr(il,i)), &
    4561      &           (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
    4562      &           /(rr(il,i)+delt*fr(il,i)), &
    4563      &           'cv30_yield 3396aO18, dtr mels')
    4564         endif !if (iso_O18.gt.0) then
    4565         endif !if (iso_HDO.gt.0) then
     4550        IF (iso_O18.gt.0) THEN
     4551          CALL iso_verif_O18_aberrant( &
     4552                 (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
     4553                 /(rr(il,i)+delt*fr(il,i)), &
     4554                 (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
     4555                 /(rr(il,i)+delt*fr(il,i)), &
     4556                 'cv30_yield 3396aO18, dtr mels')
     4557        endif !if (iso_O18.gt.0) THEN
     4558        endif !if (iso_HDO.gt.0) THEN
    45664559#ifdef ISOTRAC
    4567         call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3784')
    4568         do ixt=1,ntraciso
     4560        CALL iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3784')
     4561        DO ixt=1,ntraciso
    45694562          xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
    45704563        enddo
    4571         if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3905',1e-5) &
    4572      &           .eq.1) then
    4573               write(*,*) 'il,i=',il,i 
     4564        IF (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3905',1e-5) &
     4565                 .EQ.1) THEN
     4566              WRITE(*,*) 'il,i=',il,i
    45744567         endif
    4575 !        call iso_verif_tracpos_choix(xtnew,'cv30_yield 3905',1e-5)
    4576 #endif         
     4568!        CALL iso_verif_tracpos_choix(xtnew,'cv30_yield 3905',1e-5)
     4569#endif
    45774570#endif
    45784571#endif
    … …  
    45864579
    45874580#ifdef ISO
    4588       do ixt = 1, ntraciso
     4581      DO ixt = 1, ntraciso
    45894582      fxt(ixt,il,i)=fxt(ixt,il,i) &
    4590      &      +0.1*dpinv*ment(il,k,i) &
    4591      &           *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
     4583            +0.1*dpinv*ment(il,k,i) &
     4584                 *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
    45924585      enddo
    45934586
    45944587#ifdef DIAGISO
    45954588        fq_detrainement(il,i)=fq_detrainement(il,i) &
    4596      &   +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
     4589         +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
    45974590        f_detrainement(il,i)=f_detrainement(il,i) &
    4598      &          +0.1*dpinv*ment(il,k,i)
     4591                +0.1*dpinv*ment(il,k,i)
    45994592        q_detrainement(il,i)=q_detrainement(il,i) &
    4600      &          +0.1*dpinv*ment(il,k,i)*qent(il,k,i)
    4601        do ixt = 1, niso
     4593                +0.1*dpinv*ment(il,k,i)*qent(il,k,i)
     4594       DO ixt = 1, niso
    46024595        fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
    4603      &      +0.1*dpinv*ment(il,k,i) &
    4604      &           *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
     4596            +0.1*dpinv*ment(il,k,i) &
     4597                 *(xtent(ixt,il,k,i)-xtawat(ixt)-xt(ixt,il,i))
    46054598        xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
    4606      &          +0.1*dpinv*ment(il,k,i)*xtent(ixt,il,k,i)
     4599                +0.1*dpinv*ment(il,k,i)*xtent(ixt,il,k,i)
    46074600       enddo
    4608 #endif     
     4601#endif
    46094602
    46104603      ! cam verif
    46114604#ifdef ISOVERIF
    4612         if (iso_eau.gt.0) then
    4613               call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
    4614      &           fr(il,i),'cv30_routines 3350',errmax,errmaxrel)
    4615         endif !if (iso_eau.gt.0) then
    4616         do ixt=1,niso
    4617             call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3353')
     4605        IF (iso_eau.gt.0) THEN
     4606              CALL iso_verif_egalite_choix(fxt(iso_eau,il,i), &
     4607                 fr(il,i),'cv30_routines 3350',errmax,errmaxrel)
     4608        endif !if (iso_eau.gt.0) THEN
     4609        DO ixt=1,niso
     4610            CALL iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3353')
    46184611        enddo
    4619         if ((iso_HDO.gt.0).and. &
    4620      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    4621          call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
    4622      &                   +delt*fxt(iso_HDO,il,i)) &
    4623      &           /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3396b, dtr mels')
    4624         endif !if (iso_HDO.gt.0) then
    4625         if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
    4626      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    4627          call iso_verif_O18_aberrant( &
    4628      &           (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
    4629      &           (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
    4630      &           'cv30_yield 3396b,O18, dtr mels')
    4631         endif !if (iso_HDO.gt.0) then
     4612        IF ((iso_HDO.gt.0).AND. &
     4613                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     4614         CALL iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
     4615                         +delt*fxt(iso_HDO,il,i)) &
     4616                 /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3396b, dtr mels')
     4617        endif !if (iso_HDO.gt.0) THEN
     4618        IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0).AND. &
     4619                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     4620         CALL iso_verif_O18_aberrant( &
     4621                 (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
     4622                 (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
     4623                 'cv30_yield 3396b,O18, dtr mels')
     4624        endif !if (iso_HDO.gt.0) THEN
    46324625#ifdef ISOTRAC
    4633         call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3828')
    4634         do ixt=1,ntraciso
     4626        CALL iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3828')
     4627        DO ixt=1,ntraciso
    46354628          xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
    46364629        enddo
    4637         if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3949',1e-5) &
    4638      &           .eq.1) then
    4639               write(*,*) 'il,i=',il,i 
     4630        IF (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 3949',1e-5) &
     4631                 .EQ.1) THEN
     4632              WRITE(*,*) 'il,i=',il,i
    46404633         endif
    4641 !        call iso_verif_tracpos_choix(xtnew,'cv30_yield 3949',1e-5)
    4642 #endif         
    4643 #endif
    4644        ! end cam verif 
     4634!        CALL iso_verif_tracpos_choix(xtnew,'cv30_yield 3949',1e-5)
     4635#endif
     4636#endif
     4637       ! end cam verif
    46454638#endif
    46464639
    … …  
    46574650    ! do k=1,i-1
    46584651    ! do il=1,ncum
    4659     ! if (i.le.inb(il)) then
     4652    ! if (i.le.inb(il)) THEN
    46604653    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
    46614654    ! cpinv=1.0/cpn(il,i)
    4662     ! if (cvflag_grav) then
     4655    ! if (cvflag_grav) THEN
    46634656    ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
    46644657    ! :        *(traent(il,k,i,j)-tra(il,i,j))
    … …  
    46664659    ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
    46674660    ! :        *(traent(il,k,i,j)-tra(il,i,j))
    4668     ! endif
    4669     ! endif
     4661    ! END IF
     4662    ! END IF
    46704663    ! enddo
    46714664    ! enddo
    … …  
    46864679              ,i)-v(il,i))
    46874680#ifdef ISO
    4688        do ixt = 1, ntraciso
     4681       DO ixt = 1, ntraciso
    46894682        fxt(ixt,il,i)=fxt(ixt,il,i) &
    4690      &          +0.01*grav*dpinv*ment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
     4683                +0.01*grav*dpinv*ment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
    46914684       enddo
    46924685
    46934686#ifdef DIAGISO
    46944687       fq_detrainement(il,i)=fq_detrainement(il,i) &
    4695      &         +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
     4688               +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
    46964689       f_detrainement(il,i)=f_detrainement(il,i) &
    4697      &         +0.01*grav*dpinv*ment(il,k,i)
     4690               +0.01*grav*dpinv*ment(il,k,i)
    46984691       q_detrainement(il,i)=q_detrainement(il,i) &
    4699      &         +0.01*grav*dpinv*ment(il,k,i)*qent(il,k,i)
    4700        do ixt = 1, niso
     4692               +0.01*grav*dpinv*ment(il,k,i)*qent(il,k,i)
     4693       DO ixt = 1, niso
    47014694        fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
    4702      &   +0.01*grav*dpinv*ment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
     4695         +0.01*grav*dpinv*ment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
    47034696        xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
    4704      &          +0.01*grav*dpinv*ment(il,k,i)*xtent(ixt,il,k,i)
     4697                +0.01*grav*dpinv*ment(il,k,i)*xtent(ixt,il,k,i)
    47054698       enddo
    4706 #endif     
    4707        
     4699#endif
     4700
    47084701       ! cam verif
    47094702#ifdef ISOVERIF
    4710         if ((il.eq.1636).and.(i.eq.9)) then
    4711                 write(*,*) 'cv30 4785: on ajoute le dtr ici:'
    4712                 write(*,*) 'M=',0.01*grav*dpinv*ment(il, k, i)
    4713                 write(*,*) 'q,qe=',rr(il,i),qent(il,k,i)
     4703        IF ((il.EQ.1636).AND.(i.EQ.9)) THEN
     4704                WRITE(*,*) 'cv30 4785: on ajoute le dtr ici:'
     4705                WRITE(*,*) 'M=',0.01*grav*dpinv*ment(il, k, i)
     4706                WRITE(*,*) 'q,qe=',rr(il,i),qent(il,k,i)
    47144707                bx=0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
    4715                 do ixt=1,niso
     4708                DO ixt=1,niso
    47164709                 xtbx(ixt)=0.01*grav*dpinv*ment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
    47174710                enddo
    47184711        endif
    4719         do ixt=1,niso
    4720            call iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 4351')
    4721         enddo   
    4722 #endif       
    4723 #ifdef ISOVERIF
    4724         if (iso_eau.gt.0) then
    4725               call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
    4726      &           fr(il,i),'cv30_routines 3408',errmax,errmaxrel)
    4727         endif !if (iso_eau.gt.0) then
    4728         do ixt=1,niso
    4729             call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3411')
     4712        DO ixt=1,niso
     4713           CALL iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 4351')
    47304714        enddo
    4731         if (1.eq.0) then
    4732         if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
    4733               if (iso_verif_aberrant_enc_nostop( &
    4734      &           fxt(iso_HDO,il,i)/fr(il,i), &
    4735      &           'cv30_yield 3572, dtr mels').eq.1) then
    4736                 write(*,*) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
    4737                 write(*,*) 'fr(il,i)=',fr(il,i)
    4738 !                if (fr(il,i).gt.ridicule*1e5) then
     4715#endif
     4716#ifdef ISOVERIF
     4717        IF (iso_eau.gt.0) THEN
     4718              CALL iso_verif_egalite_choix(fxt(iso_eau,il,i), &
     4719                 fr(il,i),'cv30_routines 3408',errmax,errmaxrel)
     4720        endif !if (iso_eau.gt.0) THEN
     4721        DO ixt=1,niso
     4722            CALL iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3411')
     4723        enddo
     4724        IF (1.EQ.0) THEN
     4725        IF ((iso_HDO.gt.0).AND.(delt*fr(il,i).gt.ridicule)) THEN
     4726              IF (iso_verif_aberrant_enc_nostop( &
     4727                 fxt(iso_HDO,il,i)/fr(il,i), &
     4728                 'cv30_yield 3572, dtr mels').EQ.1) THEN
     4729                WRITE(*,*) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
     4730                WRITE(*,*) 'fr(il,i)=',fr(il,i)
     4731!                if (fr(il,i).gt.ridicule*1e5) THEN
    47394732!                 stop
    47404733!                endif
    47414734               endif
    4742         endif !if (iso_HDO.gt.0) then
    4743         endif !if (1.eq.0) then
    4744         if ((iso_HDO.gt.0).and. &
    4745      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    4746          call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
    4747      &           +delt*fxt(iso_HDO,il,i)) &
    4748      &           /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3605, dtr mels')       
    4749         if (iso_O18.gt.0) then
    4750           call iso_verif_O18_aberrant( &
    4751      &           (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
    4752      &           /(rr(il,i)+delt*fr(il,i)), &
    4753      &           (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
    4754      &           /(rr(il,i)+delt*fr(il,i)), &
    4755      &           'cv30_yield 3605O18, dtr mels')
    4756           if ((il.eq.1636).and.(i.eq.9)) then
    4757           call iso_verif_O18_aberrant( &
    4758      &           (xt(iso_HDO,il,i)+delt*(fxt(iso_HDO,il,i)-xtbx(iso_HDO))) &
    4759      &           /(rr(il,i)+delt*(fr(il,i)-bx)), &
    4760      &           (xt(iso_O18,il,i)+delt*(fxt(iso_O18,il,i)-xtbx(iso_O18))) &
    4761      &           /(rr(il,i)+delt*(fr(il,i)-bx)), &
    4762      &           'cv30_yield 3605O18_nobx, dtr mels')
    4763            endif !if ((il.eq.1636).and.(i.eq.9)) then
    4764         endif !if (iso_O18.gt.0) then
    4765         endif !if (iso_HDO.gt.0) then
     4735        endif !if (iso_HDO.gt.0) THEN
     4736        endif !if (1.EQ.0) THEN
     4737        IF ((iso_HDO.gt.0).AND. &
     4738                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     4739         CALL iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
     4740                 +delt*fxt(iso_HDO,il,i)) &
     4741                 /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3605, dtr mels')
     4742        IF (iso_O18.gt.0) THEN
     4743          CALL iso_verif_O18_aberrant( &
     4744                 (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
     4745                 /(rr(il,i)+delt*fr(il,i)), &
     4746                 (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i)) &
     4747                 /(rr(il,i)+delt*fr(il,i)), &
     4748                 'cv30_yield 3605O18, dtr mels')
     4749          IF ((il.EQ.1636).AND.(i.EQ.9)) THEN
     4750          CALL iso_verif_O18_aberrant( &
     4751                 (xt(iso_HDO,il,i)+delt*(fxt(iso_HDO,il,i)-xtbx(iso_HDO))) &
     4752                 /(rr(il,i)+delt*(fr(il,i)-bx)), &
     4753                 (xt(iso_O18,il,i)+delt*(fxt(iso_O18,il,i)-xtbx(iso_O18))) &
     4754                 /(rr(il,i)+delt*(fr(il,i)-bx)), &
     4755                 'cv30_yield 3605O18_nobx, dtr mels')
     4756           endif !if ((il.EQ.1636).AND.(i.EQ.9)) THEN
     4757        endif !if (iso_O18.gt.0) THEN
     4758        endif !if (iso_HDO.gt.0) THEN
    47664759#ifdef ISOTRAC
    4767         call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3921')
    4768         do ixt=1,ntraciso
     4760        CALL iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3921')
     4761        DO ixt=1,ntraciso
    47694762          xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
    47704763        enddo
    4771         if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4036',1e-5) &
    4772      &           .eq.1) then
    4773               write(*,*) 'il,i=',il,i 
     4764        IF (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4036',1e-5) &
     4765                 .EQ.1) THEN
     4766              WRITE(*,*) 'il,i=',il,i
    47744767         endif
    4775 !        call iso_verif_tracpos_choix(xtnew,'cv30_yield 4036',1e-5)
    4776 #endif         
    4777 #endif
    4778        ! end cam verif 
     4768!        CALL iso_verif_tracpos_choix(xtnew,'cv30_yield 4036',1e-5)
     4769#endif
     4770#endif
     4771       ! end cam verif
    47794772#endif
    47804773          ELSE ! cvflag_grav
    … …  
    47874780
    47884781#ifdef ISO
    4789        do ixt = 1, ntraciso
     4782       DO ixt = 1, ntraciso
    47904783        fxt(ixt,il,i)=fxt(ixt,il,i) &
    4791      &   +0.1*dpinv*ment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
     4784         +0.1*dpinv*ment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
    47924785       enddo
    47934786
    47944787#ifdef DIAGISO
    47954788       fq_detrainement(il,i)=fq_detrainement(il,i) &
    4796      &         +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
     4789               +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
    47974790       f_detrainement(il,i)=f_detrainement(il,i) &
    4798      &         +0.1*dpinv*ment(il,k,i)
     4791               +0.1*dpinv*ment(il,k,i)
    47994792       q_detrainement(il,i)=q_detrainement(il,i) &
    4800      &         +0.1*dpinv*ment(il,k,i)*qent(il,k,i)
    4801        do ixt = 1, niso
     4793               +0.1*dpinv*ment(il,k,i)*qent(il,k,i)
     4794       DO ixt = 1, niso
    48024795        fxt_detrainement(ixt,il,i)=fxt_detrainement(ixt,il,i) &
    4803      &   +0.1*dpinv*ment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
     4796         +0.1*dpinv*ment(il,k,i)*(xtent(ixt,il,k,i)-xt(ixt,il,i))
    48044797        xt_detrainement(ixt,il,i)=xt_detrainement(ixt,il,i) &
    4805      &          +0.1*dpinv*ment(il,k,i)*xtent(ixt,il,k,i)
     4798                +0.1*dpinv*ment(il,k,i)*xtent(ixt,il,k,i)
    48064799       enddo
    4807 #endif     
    4808        
     4800#endif
     4801
    48094802       ! cam verif
    48104803#ifdef ISOVERIF
    4811           if ((il.eq.1636).and.(i.eq.9)) then
    4812                 write(*,*) 'cv30 4785b: on ajoute le dtr ici:'
    4813                 write(*,*) 'M=',0.1*dpinv*ment(il, k, i)
    4814                 write(*,*) 'q,qe=',rr(il,i),qent(il,k,i)
     4804          IF ((il.EQ.1636).AND.(i.EQ.9)) THEN
     4805                WRITE(*,*) 'cv30 4785b: on ajoute le dtr ici:'
     4806                WRITE(*,*) 'M=',0.1*dpinv*ment(il, k, i)
     4807                WRITE(*,*) 'q,qe=',rr(il,i),qent(il,k,i)
    48154808          endif
    4816           if (iso_eau.gt.0) then
    4817               call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
    4818      &           fr(il,i),'cv30_routines 3433',errmax,errmaxrel)
    4819           endif !if (iso_eau.gt.0) then
    4820           do ixt=1,niso
    4821             call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3436')
     4809          IF (iso_eau.gt.0) THEN
     4810              CALL iso_verif_egalite_choix(fxt(iso_eau,il,i), &
     4811                 fr(il,i),'cv30_routines 3433',errmax,errmaxrel)
     4812          endif !if (iso_eau.gt.0) THEN
     4813          DO ixt=1,niso
     4814            CALL iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3436')
    48224815          enddo
    4823           if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
    4824               if (iso_verif_aberrant_enc_nostop( &
    4825      &           fxt(iso_HDO,il,i)/fr(il,i), &
    4826      &           'cv30_yield 3597').eq.1) then
    4827                 write(*,*) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
     4816          IF ((iso_HDO.gt.0).AND.(delt*fr(il,i).gt.ridicule)) THEN
     4817              IF (iso_verif_aberrant_enc_nostop( &
     4818                 fxt(iso_HDO,il,i)/fr(il,i), &
     4819                 'cv30_yield 3597').EQ.1) THEN
     4820                WRITE(*,*) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
    48284821                stop
    48294822               endif
    4830           endif !if (iso_HDO.gt.0) then
    4831           if ((iso_HDO.gt.0).and. &
    4832      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    4833            call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
    4834      &           +delt*fxt(iso_HDO,il,i)) &
    4835      &           /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3605b, dtr mels')
    4836           endif !if (iso_HDO.gt.0) then
     4823          endif !if (iso_HDO.gt.0) THEN
     4824          IF ((iso_HDO.gt.0).AND. &
     4825                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     4826           CALL iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
     4827                 +delt*fxt(iso_HDO,il,i)) &
     4828                 /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3605b, dtr mels')
     4829          endif !if (iso_HDO.gt.0) THEN
    48374830#ifdef ISOTRAC
    4838         call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3972')
    4839         do ixt=1,ntraciso
     4831        CALL iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 3972')
     4832        DO ixt=1,ntraciso
    48404833          xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
    48414834        enddo
    4842         if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4091',1e-5) &
    4843      &           .eq.1) then
    4844               write(*,*) 'il,i=',il,i 
     4835        IF (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4091',1e-5) &
     4836                 .EQ.1) THEN
     4837              WRITE(*,*) 'il,i=',il,i
    48454838         endif
    4846 !        call iso_verif_tracpos_choix(xtnew,'cv30_yield 4091',1e-5)
    4847 #endif           
    4848 #endif
    4849        ! end cam verif 
     4839!        CALL iso_verif_tracpos_choix(xtnew,'cv30_yield 4091',1e-5)
     4840#endif
     4841#endif
     4842       ! end cam verif
    48504843#endif
    48514844          END IF ! cvflag_grav
    … …  
    48574850    ! do k=i,nl+1
    48584851    ! do il=1,ncum
    4859     ! if (i.le.inb(il) .and. k.le.inb(il)) then
     4852    ! if (i.le.inb(il) .AND. k.le.inb(il)) THEN
    48604853    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
    48614854    ! cpinv=1.0/cpn(il,i)
    4862     ! if (cvflag_grav) then
     4855    ! if (cvflag_grav) THEN
    48634856    ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
    48644857    ! :         *(traent(il,k,i,j)-tra(il,i,j))
    … …  
    48664859    ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
    48674860    ! :             *(traent(il,k,i,j)-tra(il,i,j))
    4868     ! endif
    4869     ! endif ! i and k
     4861    ! END IF
     4862    ! END IF ! i and k
    48704863    ! enddo
    48714864    ! enddo
    … …  
    48894882            i))-mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
    48904883#ifdef ISO
    4891         do ixt = 1, niso
     4884        DO ixt = 1, niso
    48924885        fxt(ixt,il,i)=fxt(ixt,il,i) &
    4893      &          +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
    4894      &          +0.01*grav*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
    4895      &          -mp(il,i) &
    4896      &          *(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
     4886                +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
     4887                +0.01*grav*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
     4888                -mp(il,i) &
     4889                *(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
    48974890        enddo
    48984891
    48994892#ifdef DIAGISO
    49004893       fq_evapprecip(il,i)=fq_evapprecip(il,i) &
    4901      &           +0.5*sigd*(evap(il,i)+evap(il,i+1))
     4894                 +0.5*sigd*(evap(il,i)+evap(il,i+1))
    49024895       fq_ddft(il,i)=fq_ddft(il,i)  &
    4903      &        +0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i) &
    4904      &               *(rp(il,i)-rr(il,i-1)))*dpinv
    4905        do ixt = 1, niso
     4896              +0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i) &
     4897                     *(rp(il,i)-rr(il,i-1)))*dpinv
     4898       DO ixt = 1, niso
    49064899        fxt_evapprecip(ixt,il,i)=fxt_evapprecip(ixt,il,i) &
    4907      &   +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
     4900         +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
    49084901        fxt_ddft(ixt,il,i)=fxt_ddft(ixt,il,i) &
    4909      &   +0.01*grav*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
    4910      &              -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
    4911        enddo 
    4912 #endif             
    4913 
    4914 #ifdef ISOVERIF
    4915         do ixt=1,niso
    4916            call iso_verif_noNaN(xt(ixt,il,i),'cv30_yield 4514')
    4917            call iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 4515')
     4902         +0.01*grav*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
     4903                    -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
     4904       enddo
     4905#endif
     4906
     4907#ifdef ISOVERIF
     4908        DO ixt=1,niso
     4909           CALL iso_verif_noNaN(xt(ixt,il,i),'cv30_yield 4514')
     4910           CALL iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 4515')
    49184911        enddo
    4919         if ((iso_HDO.gt.0).and. &
    4920      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    4921         if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
    4922      &           +delt*fxt(iso_HDO,il,i)) &
    4923      &           /(rr(il,i)+delt*fr(il,i)),'cv30_yield 4175') &
    4924      &           .eq.1) then
    4925         write(*,*) 'il,i=',il,i
    4926         if (rr(il,i).ne.0.0) then
    4927         write(*,*) 'il,i,rr,deltaD=',il,i,rr(il,i),deltaD &
    4928      &           (xt(iso_HDO,il,i)/rr(il,i))
     4912        IF ((iso_HDO.gt.0).AND. &
     4913                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     4914        IF (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
     4915                 +delt*fxt(iso_HDO,il,i)) &
     4916                 /(rr(il,i)+delt*fr(il,i)),'cv30_yield 4175') &
     4917                 .EQ.1) THEN
     4918        WRITE(*,*) 'il,i=',il,i
     4919        IF (rr(il,i).NE.0.0) THEN
     4920        WRITE(*,*) 'il,i,rr,deltaD=',il,i,rr(il,i),deltaD &
     4921                 (xt(iso_HDO,il,i)/rr(il,i))
    49294922        endif
    4930         if (fr(il,i).ne.0.0) then
    4931         write(*,*) 'fr,fxt,deltaD=',fr(il,i),fxt(iso_HDO,il,i), &
    4932      &           deltaD(fxt(iso_HDO,il,i)/fr(il,i))
     4923        IF (fr(il,i).NE.0.0) THEN
     4924        WRITE(*,*) 'fr,fxt,deltaD=',fr(il,i),fxt(iso_HDO,il,i), &
     4925                 deltaD(fxt(iso_HDO,il,i)/fr(il,i))
    49334926        endif
    4934 #ifdef DIAGISO       
    4935         if (fq_ddft(il,i).ne.0.0) then
    4936         write(*,*) 'fq_ddft,deltaD=',fq_ddft(il,i),deltaD( &
    4937      &           fxt_ddft(iso_HDO,il,i)/fq_ddft(il,i))
     4927#ifdef DIAGISO
     4928        IF (fq_ddft(il,i).NE.0.0) THEN
     4929        WRITE(*,*) 'fq_ddft,deltaD=',fq_ddft(il,i),deltaD( &
     4930                 fxt_ddft(iso_HDO,il,i)/fq_ddft(il,i))
    49384931        endif
    4939         if (fq_evapprecip(il,i).ne.0.0) then
    4940         write(*,*) 'fq_evapprecip,deltaD=',fq_evapprecip(il,i),deltaD( &
    4941      &           fxt_evapprecip(iso_HDO,il,i)/fq_evapprecip(il,i))
     4932        IF (fq_evapprecip(il,i).NE.0.0) THEN
     4933        WRITE(*,*) 'fq_evapprecip,deltaD=',fq_evapprecip(il,i),deltaD( &
     4934                 fxt_evapprecip(iso_HDO,il,i)/fq_evapprecip(il,i))
    49424935        endif
    4943 #endif       
    4944         write(*,*) 'sigd,evap(il,i),evap(il,i+1)=', &
    4945      &            sigd,evap(il,i),evap(il,i+1)
    4946         write(*,*) 'xtevap(iso_HDO,il,i),xtevap(iso_HDO,il,i+1)=', &
    4947      &           xtevap(iso_HDO,il,i),xtevap(iso_HDO,il,i+1)
    4948         write(*,*) 'grav,mp(il,i+1),mp(il,i),dpinv=', &
    4949      &           grav,mp(il,i+1),mp(il,i),dpinv
    4950         write(*,*) 'rp(il,i+1),rr(il,i),rp(il,i),rr(il,i-1)=', &
    4951      &           rp(il,i+1),rr(il,i),rp(il,i),rr(il,i-1)
    4952         write(*,*) 'xtp(il,i+1),xt(il,i),xtp(il,i),xt(il,i-1)=', &
    4953      &           xtp(iso_HDO,il,i+1),xt(iso_HDO,il,i), &
    4954      &           xtp(iso_HDO,il,i),xt(iso_HDO,il,i-1)
     4936#endif
     4937        WRITE(*,*) 'sigd,evap(il,i),evap(il,i+1)=', &
     4938                  sigd,evap(il,i),evap(il,i+1)
     4939        WRITE(*,*) 'xtevap(iso_HDO,il,i),xtevap(iso_HDO,il,i+1)=', &
     4940                 xtevap(iso_HDO,il,i),xtevap(iso_HDO,il,i+1)
     4941        WRITE(*,*) 'grav,mp(il,i+1),mp(il,i),dpinv=', &
     4942                 grav,mp(il,i+1),mp(il,i),dpinv
     4943        WRITE(*,*) 'rp(il,i+1),rr(il,i),rp(il,i),rr(il,i-1)=', &
     4944                 rp(il,i+1),rr(il,i),rp(il,i),rr(il,i-1)
     4945        WRITE(*,*) 'xtp(il,i+1),xt(il,i),xtp(il,i),xt(il,i-1)=', &
     4946                 xtp(iso_HDO,il,i+1),xt(iso_HDO,il,i), &
     4947                 xtp(iso_HDO,il,i),xt(iso_HDO,il,i-1)
    49554948        stop
    49564949        endif
    4957         endif !if (iso_HDO.gt.0) then
    4958         if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
    4959      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    4960          call iso_verif_O18_aberrant( &
    4961      &       (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
    4962      &       (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
    4963      &       'cv30_yield 5029,O18, evap')
    4964           if ((il.eq.1636).and.(i.eq.9)) then
    4965             write(*,*) 'cv30_yield 5057: ici, on verifie deltaD_nobx'
    4966             write(*,*) 'il,i=',il,i
    4967             write(*,*) 'fr(il,i),bx,fr(il,i)-bx=',fr(il,i),bx,fr(il,i)-bx
    4968             write(*,*) 'q,q+=',rr(il,i),rr(il,i)+delt*(fr(il,i)-bx)
    4969             write(*,*) 'deltaD,deltaD+=',deltaD(xt(iso_HDO,il,inb(il))/rr(il,inb(il))), &
    4970      &          deltaD( (xt(iso_HDO,il,i)+delt*(fxt(iso_HDO,il,i)-xtbx(iso_HDO)))/(rr(il,i)+delt*(fr(il,i)-bx)))
    4971             write(*,*) 'deltaO18,deltaO18+=',deltaO(xt(iso_O18,il,inb(il))/rr(il,inb(il))), &
    4972      &          deltaO( (xt(iso_O18,il,i)+delt*(fxt(iso_O18,il,i)-xtbx(iso_O18)))/(rr(il,i)+delt*(fr(il,i)-bx)))
    4973             call iso_verif_O18_aberrant( &
    4974      &           (xt(iso_HDO,il,i)+delt*(fxt(iso_HDO,il,i)-xtbx(iso_HDO))) &
    4975      &           /(rr(il,i)+delt*(fr(il,i)-bx)), &
    4976      &           (xt(iso_O18,il,i)+delt*(fxt(iso_O18,il,i)-xtbx(iso_O18))) &
    4977      &           /(rr(il,i)+delt*(fr(il,i)-bx)), &
    4978      &          'cv30_yield 5029_nobx,O18, evap, no bx')
    4979           endif !if ((il.eq.1636).and.(i.eq.9)) then
    4980           endif !if (iso_HDO.gt.0) then
     4950        endif !if (iso_HDO.gt.0) THEN
     4951        IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0).AND. &
     4952                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     4953         CALL iso_verif_O18_aberrant( &
     4954             (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
     4955             (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
     4956             'cv30_yield 5029,O18, evap')
     4957          IF ((il.EQ.1636).AND.(i.EQ.9)) THEN
     4958            WRITE(*,*) 'cv30_yield 5057: ici, on verifie deltaD_nobx'
     4959            WRITE(*,*) 'il,i=',il,i
     4960            WRITE(*,*) 'fr(il,i),bx,fr(il,i)-bx=',fr(il,i),bx,fr(il,i)-bx
     4961            WRITE(*,*) 'q,q+=',rr(il,i),rr(il,i)+delt*(fr(il,i)-bx)
     4962            WRITE(*,*) 'deltaD,deltaD+=',deltaD(xt(iso_HDO,il,inb(il))/rr(il,inb(il))), &
     4963                deltaD( (xt(iso_HDO,il,i)+delt*(fxt(iso_HDO,il,i)-xtbx(iso_HDO)))/(rr(il,i)+delt*(fr(il,i)-bx)))
     4964            WRITE(*,*) 'deltaO18,deltaO18+=',deltaO(xt(iso_O18,il,inb(il))/rr(il,inb(il))), &
     4965                deltaO( (xt(iso_O18,il,i)+delt*(fxt(iso_O18,il,i)-xtbx(iso_O18)))/(rr(il,i)+delt*(fr(il,i)-bx)))
     4966            CALL iso_verif_O18_aberrant( &
     4967                 (xt(iso_HDO,il,i)+delt*(fxt(iso_HDO,il,i)-xtbx(iso_HDO))) &
     4968                 /(rr(il,i)+delt*(fr(il,i)-bx)), &
     4969                 (xt(iso_O18,il,i)+delt*(fxt(iso_O18,il,i)-xtbx(iso_O18))) &
     4970                 /(rr(il,i)+delt*(fr(il,i)-bx)), &
     4971                'cv30_yield 5029_nobx,O18, evap, no bx')
     4972          endif !if ((il.EQ.1636).AND.(i.EQ.9)) THEN
     4973          endif !if (iso_HDO.gt.0) THEN
    49814974#endif
    49824975
    49834976#ifdef ISOTRAC
    4984         if ((option_traceurs.ne.6).and.(option_traceurs.ne.19)) then
    4985 
     4977        IF ((option_traceurs.NE.6).AND.(option_traceurs.NE.19)) THEN
    49864978            ! facile: on fait comme l'eau
    4987             do ixt = 1+niso,ntraciso
     4979            DO ixt = 1+niso,ntraciso
    49884980             fxt(ixt,il,i)=fxt(ixt,il,i) &
    4989      &          +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
    4990      &          +0.01*grav*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
    4991      &              -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
    4992             enddo !do ixt = 1+niso,ntraciso           
     4981                +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
     4982                +0.01*grav*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
     4983                    -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
     4984            enddo !do ixt = 1+niso,ntraciso
    49934985
    49944986        else ! taggage des ddfts:
    … …  
    50024994!             fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+conversion(iiso)
    50034995!             fxt(ixt_poubelle,il,i)=fxt(ixt_poubelle,il,i)
    5004 !     :           -conversion(iiso)   
     4996!     :           -conversion(iiso)
    50054997
    50064998        ! Pb: quand on discretise, dqp/dt n'est pas verifee numeriquement.
    … …  
    50105002        ! Solution alternative: Dans le cas entrainant, Ye ne varie que par
    50115003        ! ascendance compensatoire des ddfts et par perte de Ye vers le ddft. On
    5012         ! calcule donc ce terme directement avec schema amont: 
     5004        ! calcule donc ce terme directement avec schema amont:
    50135005
    50145006        ! ajout deja de l'evap
    5015         do ixt = 1+niso,ntraciso
     5007        DO ixt = 1+niso,ntraciso
    50165008             fxt(ixt,il,i)=fxt(ixt,il,i) &
    5017      &          +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
     5009                +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
    50185010        enddo !do ixt = 1+niso,ntraciso
    50195011
    50205012        ! ajout du terme des ddfts sensi stricto
    5021 !        write(*,*) 'tmp cv3_yield 4165: i,il=',i,il
    5022 !
    5023         if (option_traceurs.eq.6) then
    5024           do iiso = 1, niso
    5025              
    5026              ixt_ddft=itZonIso(izone_ddft,iiso) 
    5027              if (mp(il,i).gt.mp(il,i+1)) then
     5013!        WRITE(*,*) 'tmp cv3_yield 4165: i,il=',i,il
     5014
     5015        IF (option_traceurs.EQ.6) THEN
     5016          DO iiso = 1, niso
     5017
     5018             ixt_ddft=itZonIso(izone_ddft,iiso)
     5019             IF (mp(il,i).gt.mp(il,i+1)) THEN
    50285020                fxtYe(iiso)=0.01*grav*dpinv*mp(il,i) &
    5029      &           *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
    5030              else !if (mp(il,i).gt.mp(il,i+1)) then
     5021                 *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
     5022             else !if (mp(il,i).gt.mp(il,i+1)) THEN
    50315023                fxtYe(iiso)=0.01*grav*dpinv*(mp(il,i) &
    5032      &           *xt(ixt_ddft,il,i-1)-mp(il,i+1)*xt(ixt_ddft,il,i) &
    5033      &           +(mp(il,i+1)-mp(il,i))*xtp(ixt_ddft,il,i))       
    5034              endif !if (mp(il,i).gt.mp(il,i+1)) then
     5024                 *xt(ixt_ddft,il,i-1)-mp(il,i+1)*xt(ixt_ddft,il,i) &
     5025                 +(mp(il,i+1)-mp(il,i))*xtp(ixt_ddft,il,i))
     5026             endif !if (mp(il,i).gt.mp(il,i+1)) THEN
    50355027             fxtqe(iiso)=0.01*grav*dpinv* &
    5036      &              (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
    5037      &              -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
    5038        
     5028                    (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
     5029                    -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
     5030
    50395031             ixt_poubelle=itZonIso(izone_poubelle,iiso)
    50405032             fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+fxtYe(iiso)
    50415033             fxt(ixt_poubelle,il,i)=fxt(ixt_poubelle,il,i) &
    5042      &           +fxtqe(iiso)-fxtYe(iiso)
     5034                 +fxtqe(iiso)-fxtYe(iiso)
    50435035         enddo !do iiso = 1, niso
    50445036
    5045          else !if (option_traceurs.eq.6) then
    5046 
    5047 
    5048             if (mp(il,i).gt.mp(il,i+1)) then
     5037         else !if (option_traceurs.EQ.6) THEN
     5038            IF (mp(il,i).gt.mp(il,i+1)) THEN
    50495039                ! cas entrainant: faire attention
    5050                
    5051                 do iiso = 1, niso
     5040
     5041                DO iiso = 1, niso
    50525042                fxtqe(iiso)=0.01*grav*dpinv* &
    5053      &              (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
    5054      &              -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
    5055 
    5056                 ixt_ddft=itZonIso(izone_ddft,iiso) 
     5043                    (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
     5044                    -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
     5045
     5046                ixt_ddft=itZonIso(izone_ddft,iiso)
    50575047                fxtYe(iiso)=0.01*grav*dpinv*mp(il,i) &
    5058      &           *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
    5059                 fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+fxtYe(iiso) 
    5060 
    5061                ixt_revap=itZonIso(izone_revap,iiso) 
     5048                 *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
     5049                fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+fxtYe(iiso)
     5050
     5051               ixt_revap=itZonIso(izone_revap,iiso)
    50625052               fxt_revap(iiso)=0.01*grav*dpinv*(mp(il,i+1)* &
    5063      &                  (xtp(ixt_revap,il,i+1)-xt(ixt_revap,il,i)) &
    5064      &                  -mp(il,i)*(xtp(ixt_revap,il,i)-xt(ixt_revap,il,i-1)))     
     5053                        (xtp(ixt_revap,il,i+1)-xt(ixt_revap,il,i)) &
     5054                        -mp(il,i)*(xtp(ixt_revap,il,i)-xt(ixt_revap,il,i-1)))
    50655055               fxt(ixt_revap,il,i)=fxt(ixt_revap,il,i) &
    5066      &                  +fxt_revap(iiso)
     5056                        +fxt_revap(iiso)
    50675057
    50685058                fxtXe(iiso)=fxtqe(iiso)-fxtYe(iiso)-fxt_revap(iiso)
    50695059                Xe(iiso)=xt(iiso,il,i) &
    5070      &                   -xt(ixt_ddft,il,i)-xt(ixt_revap,il,i)
    5071                 if (Xe(iiso).gt.ridicule) then
    5072                   do izone=1,nzone
    5073                    if ((izone.ne.izone_revap).and. &
    5074      &                   (izone.ne.izone_ddft)) then
    5075                     ixt=itZonIso(izone,iiso) 
     5060                         -xt(ixt_ddft,il,i)-xt(ixt_revap,il,i)
     5061                IF (Xe(iiso).gt.ridicule) THEN
     5062                  DO izone=1,nzone
     5063                   IF ((izone.NE.izone_revap).AND. &
     5064                         (izone.NE.izone_ddft)) THEN
     5065                    ixt=itZonIso(izone,iiso)
    50765066                    fxt(ixt,il,i)=fxt(ixt,il,i) &
    5077      &                   +xt(ixt,il,i)/Xe(iiso)*fxtXe(iiso)
    5078                    endif !if ((izone.ne.izone_revap).and.
    5079                   enddo !do izone=1,nzone   
    5080 #ifdef ISOVERIF
    5081 !                write(*,*) 'iiso=',iiso
    5082 !                write(*,*) 'fxtqe=',fxtqe(iiso)
    5083 !                write(*,*) 'fxtYe=',fxtYe(iiso)
    5084 !                write(*,*) 'fxt_revap=',fxt_revap(iiso)
    5085 !                write(*,*) 'fxtXe=',fxtXe(iiso)
    5086 !                write(*,*) 'Xe=',Xe(iiso)
    5087 !                write(*,*) 'xt=',xt(:,il,i)
    5088                   call iso_verif_traceur_justmass(fxt(1,il,i), &
    5089      &                   'cv30_routine 4646')
    5090 #endif
    5091                 else !if (abs(dXe).gt.ridicule) then
     5067                         +xt(ixt,il,i)/Xe(iiso)*fxtXe(iiso)
     5068                   endif !if ((izone.NE.izone_revap).AND.
     5069                  enddo !do izone=1,nzone
     5070#ifdef ISOVERIF
     5071!                WRITE(*,*) 'iiso=',iiso
     5072!                WRITE(*,*) 'fxtqe=',fxtqe(iiso)
     5073!                WRITE(*,*) 'fxtYe=',fxtYe(iiso)
     5074!                WRITE(*,*) 'fxt_revap=',fxt_revap(iiso)
     5075!                WRITE(*,*) 'fxtXe=',fxtXe(iiso)
     5076!                WRITE(*,*) 'Xe=',Xe(iiso)
     5077!                WRITE(*,*) 'xt=',xt(:,il,i)
     5078                  CALL iso_verif_traceur_justmass(fxt(1,il,i), &
     5079                         'cv30_routine 4646')
     5080#endif
     5081                else !if (abs(dXe).gt.ridicule) THEN
    50925082                    ! dans ce cas, fxtXe doit etre faible
    5093                    
    5094 #ifdef ISOVERIF
    5095                 if (delt*fxtXe(iiso).gt.ridicule) then
    5096                    write(*,*) 'cv30_routines 6563: delt*fxtXe(iiso)=', &
    5097      &                          delt*fxtXe(iiso)
     5083
     5084#ifdef ISOVERIF
     5085                IF (delt*fxtXe(iiso).gt.ridicule) THEN
     5086                   WRITE(*,*) 'cv30_routines 6563: delt*fxtXe(iiso)=', &
     5087                                delt*fxtXe(iiso)
    50985088                   stop
    50995089                endif
    5100 #endif                   
    5101                 do izone=1,nzone
    5102                    if ((izone.ne.izone_revap).and. &
    5103      &                   (izone.ne.izone_ddft)) then                   
    5104                     ixt=itZonIso(izone,iiso) 
    5105                     if (izone.eq.izone_poubelle) then
     5090#endif
     5091                DO izone=1,nzone
     5092                   IF ((izone.NE.izone_revap).AND. &
     5093                         (izone.NE.izone_ddft)) THEN
     5094                    ixt=itZonIso(izone,iiso)
     5095                    IF (izone.EQ.izone_poubelle) THEN
    51065096                      fxt(ixt,il,i)=fxt(ixt,il,i)+fxtXe(iiso)
    5107                     else !if (izone.eq.izone_poubelle) then
     5097                    else !if (izone.EQ.izone_poubelle) THEN
    51085098                        ! pas de tendance pour ce tag la
    5109                     endif !if (izone.eq.izone_poubelle) then
    5110                    endif !if ((izone.ne.izone_revap).and.
     5099                    endif !if (izone.EQ.izone_poubelle) THEN
     5100                   endif !if ((izone.NE.izone_revap).AND.
    51115101                enddo !do izone=1,nzone
    51125102#ifdef ISOVERIF
    5113                   call iso_verif_traceur_justmass(fxt(1,il,i), &
    5114      &                   'cv30_routine 4671')
    5115 #endif             
    5116                                            
    5117                 endif !if (abs(dXe).gt.ridicule) then
    5118 
     5103                  CALL iso_verif_traceur_justmass(fxt(1,il,i), &
     5104                         'cv30_routine 4671')
     5105#endif
     5106
     5107                endif !if (abs(dXe).gt.ridicule) THEN
    51195108              enddo !do iiso = 1, niso
    5120                
    5121             else !if (mp(il,i).gt.mp(il,i+1)) then
     5109
     5110            else !if (mp(il,i).gt.mp(il,i+1)) THEN
    51225111                ! cas detrainant: pas de problemes
    5123                 do ixt=1+niso,ntraciso
     5112                DO ixt=1+niso,ntraciso
    51245113                fxt(ixt,il,i)=fxt(ixt,il,i) &
    5125      &                  +0.01*grav*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
    5126      &                  -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
     5114                        +0.01*grav*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
     5115                        -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
    51275116                enddo !do ixt=1+niso,ntraciso
    51285117#ifdef ISOVERIF
    5129                   call iso_verif_traceur_justmass(fxt(1,il,i), &
    5130      &                   'cv30_routine 4685')
    5131 #endif               
    5132             endif !if (mp(il,i).gt.mp(il,i+1)) then
    5133 
    5134           endif !if (option_traceurs.eq.6) then
    5135 
    5136 !          write(*,*) 'delt*conversion=',delt*conversion(iso_eau)
    5137 !           write(*,*) 'delt*fxtYe=',delt*fxtYe(iso_eau)
    5138 !           write(*,*) 'delt*fxtqe=',delt*fxtqe(iso_eau)                 
    5139 
    5140         endif ! if ((option_traceurs.ne.6).and.(option_traceurs.ne.19)) then
    5141 #endif
    5142        
     5118                  CALL iso_verif_traceur_justmass(fxt(1,il,i), &
     5119                         'cv30_routine 4685')
     5120#endif
     5121            endif !if (mp(il,i).gt.mp(il,i+1)) THEN
     5122          endif !if (option_traceurs.EQ.6) THEN
     5123!          WRITE(*,*) 'delt*conversion=',delt*conversion(iso_eau)
     5124!           WRITE(*,*) 'delt*fxtYe=',delt*fxtYe(iso_eau)
     5125!           WRITE(*,*) 'delt*fxtqe=',delt*fxtqe(iso_eau)
     5126
     5127        endif ! if ((option_traceurs.NE.6).AND.(option_traceurs.NE.19)) THEN
     5128#endif
     5129
    51435130        ! cam verif
    51445131#ifdef ISOVERIF
    5145           do ixt=1,niso
    5146             call iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3496')
     5132          DO ixt=1,niso
     5133            CALL iso_verif_noNAN(fxt(ixt,il,i),'cv30_routines 3496')
    51475134          enddo
    51485135#endif
    51495136#ifdef ISOVERIF
    5150           if (iso_eau.gt.0) then
    5151               call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
    5152      &           fr(il,i),'cv30_routines 3493',errmax,errmaxrel)
    5153           endif !if (iso_eau.gt.0) then
    5154           if (1.eq.0) then
    5155           if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
    5156               if (iso_verif_aberrant_enc_nostop( &
    5157      &           fxt(iso_HDO,il,i)/fr(il,i), &
    5158      &           'cv30_yield 3662').eq.1) then
    5159                 write(*,*) 'il,i,icb(il),inb(il)=',il,i,icb(il),inb(il)
    5160                 write(*,*) 'fr(il,i),delt=',fr(il,i),delt
    5161 #ifdef DIAGISO                       
    5162                 if (fq_ddft(il,i).ne.0.0) then
    5163                 write(*,*) 'fq_ddft,deltaD=',fq_ddft(il,i),deltaD( &
    5164      &             fxt_ddft(iso_HDO,il,i)/fq_ddft(il,i))
    5165                 endif !if (fq_ddft(il,i).ne.0.0) then
    5166                 if (fq_evapprecip(il,i).ne.0.0) then
    5167                 write(*,*) 'fq_evapprecip,deltaD=',fq_evapprecip(il,i), &
    5168      &             deltaD(fxt_evapprecip(iso_HDO,il,i) &
    5169      &             /fq_evapprecip(il,i))
    5170                 endif !if (fq_evapprecip(il,i).ne.0.0) then
    5171 #endif               
     5137          IF (iso_eau.gt.0) THEN
     5138              CALL iso_verif_egalite_choix(fxt(iso_eau,il,i), &
     5139                 fr(il,i),'cv30_routines 3493',errmax,errmaxrel)
     5140          endif !if (iso_eau.gt.0) THEN
     5141          IF (1.EQ.0) THEN
     5142          IF ((iso_HDO.gt.0).AND.(delt*fr(il,i).gt.ridicule)) THEN
     5143              IF (iso_verif_aberrant_enc_nostop( &
     5144                 fxt(iso_HDO,il,i)/fr(il,i), &
     5145                 'cv30_yield 3662').EQ.1) THEN
     5146                WRITE(*,*) 'il,i,icb(il),inb(il)=',il,i,icb(il),inb(il)
     5147                WRITE(*,*) 'fr(il,i),delt=',fr(il,i),delt
     5148#ifdef DIAGISO
     5149                IF (fq_ddft(il,i).NE.0.0) THEN
     5150                WRITE(*,*) 'fq_ddft,deltaD=',fq_ddft(il,i),deltaD( &
     5151                   fxt_ddft(iso_HDO,il,i)/fq_ddft(il,i))
     5152                endif !if (fq_ddft(il,i).NE.0.0) THEN
     5153                IF (fq_evapprecip(il,i).NE.0.0) THEN
     5154                WRITE(*,*) 'fq_evapprecip,deltaD=',fq_evapprecip(il,i), &
     5155                   deltaD(fxt_evapprecip(iso_HDO,il,i) &
     5156                   /fq_evapprecip(il,i))
     5157                endif !if (fq_evapprecip(il,i).NE.0.0) THEN
     5158#endif
    51725159               endif !if (iso_verif_aberrant_enc_nostop(
    5173           endif !if (iso_HDO.gt.0) then
    5174           endif !if (1.eq.0) then
    5175           if ((iso_HDO.gt.0).and. &
    5176      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    5177            if (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
    5178      &           +delt*fxt(iso_HDO,il,i)) &
    5179      &           /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3757, ddfts') &
    5180      &           .eq.1) then
    5181                 write(*,*) 'i,il,q,deltaD=',i,il,rr(il,i),deltaD( &
    5182      &             xt(iso_HDO,il,i)/rr(il,i))
    5183                 write(*,*) 'i,il,fr,deltaD=',i,il,fr(il,i),deltaD( &
    5184      &             fxt(iso_HDO,il,i)/fr(il,i))
     5160          endif !if (iso_HDO.gt.0) THEN
     5161          endif !if (1.EQ.0) THEN
     5162          IF ((iso_HDO.gt.0).AND. &
     5163                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     5164           IF (iso_verif_aberrant_enc_nostop((xt(iso_HDO,il,i) &
     5165                 +delt*fxt(iso_HDO,il,i)) &
     5166                 /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3757, ddfts') &
     5167                 .EQ.1) THEN
     5168                WRITE(*,*) 'i,il,q,deltaD=',i,il,rr(il,i),deltaD( &
     5169                   xt(iso_HDO,il,i)/rr(il,i))
     5170                WRITE(*,*) 'i,il,fr,deltaD=',i,il,fr(il,i),deltaD( &
     5171                   fxt(iso_HDO,il,i)/fr(il,i))
    51855172                stop
    51865173            endif ! if (iso_verif_aberrant_enc_nostop
    5187         endif !if (iso_HDO.gt.0) then
    5188        
    5189         if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
    5190      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    5191          call iso_verif_O18_aberrant( &
    5192      &       (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
    5193      &       (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
    5194      &       'cv30_yield 5250,O18, ddfts')
    5195           endif !if (iso_HDO.gt.0) then
    5196 
     5174        endif !if (iso_HDO.gt.0) THEN
     5175        IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0).AND. &
     5176                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     5177         CALL iso_verif_O18_aberrant( &
     5178             (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
     5179             (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
     5180             'cv30_yield 5250,O18, ddfts')
     5181          endif !if (iso_HDO.gt.0) THEN
    51975182#ifdef ISOTRAC
    5198 !        write(*,*) 'tmp cv3_yield 4224: i,il=',i,il
    5199         call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 4107')
    5200         do ixt=1,ntraciso
     5183!        WRITE(*,*) 'tmp cv3_yield 4224: i,il=',i,il
     5184        CALL iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 4107')
     5185        DO ixt=1,ntraciso
    52015186          xtnew(ixt)=xt(ixt,il,i)+delt*fxt(ixt,il,i)
    52025187        enddo
    5203         if (iso_verif_tracpos_choix_nostop(xtnew, &
    5204      &                  'cv30_yield 4221',1e-5).eq.1) then
    5205           write(*,*) 'delt*fxt(,il,i)=',delt*fxt(1:ntraciso:2,il,i)
    5206           write(*,*) 'delt*fxt(,il,i)=',delt*fxt(:,il,i)
    5207           write(*,*) 'xt(,il,i)=',xt(:,il,i)
    5208           write(*,*) 'delt,sigd,grav,dpinv=',delt,sigd,grav,dpinv
    5209           write(*,*) 'xtevap(,il,i)=',xtevap(:,il,i)
    5210           write(*,*) 'xtevap(,il,i+1)=',xtevap(:,il,i+1)
    5211           write(*,*) 'mp(il,i+1),mp(il,i)=',mp(il,i+1),mp(il,i)
    5212           write(*,*) 'xtp(,il,i)=',xtp(:,il,i)
    5213           write(*,*) 'xtp(,il,i+1)=',xtp(:,il,i+1)
    5214           write(*,*) 'xt(,il,i)=',xt(:,il,i)
    5215           write(*,*) 'xt(,il,i-1)=',xt(:,il,i-1)
     5188        IF (iso_verif_tracpos_choix_nostop(xtnew, &
     5189                        'cv30_yield 4221',1e-5).EQ.1) THEN
     5190          WRITE(*,*) 'delt*fxt(,il,i)=',delt*fxt(1:ntraciso:2,il,i)
     5191          WRITE(*,*) 'delt*fxt(,il,i)=',delt*fxt(:,il,i)
     5192          WRITE(*,*) 'xt(,il,i)=',xt(:,il,i)
     5193          WRITE(*,*) 'delt,sigd,grav,dpinv=',delt,sigd,grav,dpinv
     5194          WRITE(*,*) 'xtevap(,il,i)=',xtevap(:,il,i)
     5195          WRITE(*,*) 'xtevap(,il,i+1)=',xtevap(:,il,i+1)
     5196          WRITE(*,*) 'mp(il,i+1),mp(il,i)=',mp(il,i+1),mp(il,i)
     5197          WRITE(*,*) 'xtp(,il,i)=',xtp(:,il,i)
     5198          WRITE(*,*) 'xtp(,il,i+1)=',xtp(:,il,i+1)
     5199          WRITE(*,*) 'xt(,il,i)=',xt(:,il,i)
     5200          WRITE(*,*) 'xt(,il,i-1)=',xt(:,il,i-1)
    52165201!         rappel: fxt(ixt,il,i)=fxt(ixt,il,i)
    52175202!          0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
    … …  
    52205205!          stop
    52215206        endif
    5222 #endif           
     5207#endif
    52235208#endif
    52245209#endif
    … …  
    52325217            i))-mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
    52335218#ifdef ISO
    5234         do ixt = 1, ntraciso
     5219        DO ixt = 1, ntraciso
    52355220        fxt(ixt,il,i)=fxt(ixt,il,i) &
    5236      &   +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
    5237      &   +0.1*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
    5238      &        -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
     5221         +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
     5222         +0.1*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
     5223              -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
    52395224        enddo ! ixt=1,niso
    52405225
    5241 #ifdef ISOTRAC       
    5242         if (option_traceurs.ne.6) then
    5243 
     5226#ifdef ISOTRAC
     5227        IF (option_traceurs.NE.6) THEN
    52445228            ! facile: on fait comme l'eau
    5245             do ixt = 1+niso,ntraciso
     5229            DO ixt = 1+niso,ntraciso
    52465230             fxt(ixt,il,i)=fxt(ixt,il,i) &
    5247      &          +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
    5248      &          +0.01*grav*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
    5249      &              -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
     5231                +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1)) &
     5232                +0.01*grav*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
     5233                    -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
    52505234            enddo !do ixt = 1+niso,ntraciso
    52515235
    5252         else  !if (option_traceurs.ne.6) then
    5253 
     5236        else  !if (option_traceurs.NE.6) THEN
    52545237            ! taggage des ddfts:  voir blabla + haut
    5255         do ixt = 1+niso,ntraciso
     5238        DO ixt = 1+niso,ntraciso
    52565239             fxt(ixt,il,i)=fxt(ixt,il,i) &
    5257      &          +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
     5240                +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
    52585241        enddo !do ixt = 1+niso,ntraciso
    5259 !        write(*,*) 'tmp cv3_yield 4165: i,il=',i,il
     5242!        WRITE(*,*) 'tmp cv3_yield 4165: i,il=',i,il
    52605243!        ixt_poubelle=itZonIso(izone_poubelle,iso_eau)
    52615244!        ixt_ddft=itZonIso(izone_ddft,iso_eau)
    5262 !        write(*,*) 'delt*fxt(ixt_poubelle,il,i)=',
     5245!        WRITE(*,*) 'delt*fxt(ixt_poubelle,il,i)=',
    52635246!     :           delt*fxt(ixt_poubelle,il,i)
    5264 !        write(*,*) 'delt*fxt(ixt_ddft,il,i)=',delt*fxt(ixt_ddft,il,i)
    5265 !        write(*,*) 'xt(iso_eau,il,i)=',xt(iso_eau,il,i)
    5266           do iiso = 1, niso
     5247!        WRITE(*,*) 'delt*fxt(ixt_ddft,il,i)=',delt*fxt(ixt_ddft,il,i)
     5248!        WRITE(*,*) 'xt(iso_eau,il,i)=',xt(iso_eau,il,i)
     5249          DO iiso = 1, niso
    52675250             ixt_poubelle=itZonIso(izone_poubelle,iiso)
    5268              ixt_ddft=itZonIso(izone_ddft,iiso) 
    5269              if (mp(il,i).gt.mp(il,i+1)) then
     5251             ixt_ddft=itZonIso(izone_ddft,iiso)
     5252             IF (mp(il,i).gt.mp(il,i+1)) THEN
    52705253                fxtYe(iiso)=0.01*grav*dpinv*mp(il,i) &
    5271      &           *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
    5272              else !if (mp(il,i).gt.mp(il,i+1)) then
     5254                 *(xt(ixt_ddft,il,i-1)-xt(ixt_ddft,il,i))
     5255             else !if (mp(il,i).gt.mp(il,i+1)) THEN
    52735256                fxtYe(iiso)=0.01*grav*dpinv*(mp(il,i) &
    5274      &           *xt(ixt_ddft,il,i-1)-mp(il,i+1)*xt(ixt_ddft,il,i) &
    5275      &           +(mp(il,i+1)-mp(il,i))*xtp(ixt_ddft,il,i))       
    5276              endif !if (mp(il,i).gt.mp(il,i+1)) then
     5257                 *xt(ixt_ddft,il,i-1)-mp(il,i+1)*xt(ixt_ddft,il,i) &
     5258                 +(mp(il,i+1)-mp(il,i))*xtp(ixt_ddft,il,i))
     5259             endif !if (mp(il,i).gt.mp(il,i+1)) THEN
    52775260             fxtqe(iiso)=0.01*grav*dpinv* &
    5278      &              (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
    5279      &              -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
     5261                    (mp(il,i+1)*(xtp(iiso,il,i+1)-xt(iiso,il,i)) &
     5262                    -mp(il,i)*(xtp(iiso,il,i)-xt(iiso,il,i-1)))
    52805263             fxt(ixt_ddft,il,i)=fxt(ixt_ddft,il,i)+fxtYe(iiso)
    52815264             fxt(ixt_poubelle,il,i)=fxt(ixt_poubelle,il,i) &
    5282      &           +fxtqe(iiso)-fxtYe(iiso)
     5265                 +fxtqe(iiso)-fxtYe(iiso)
    52835266          enddo !do iiso = 1, niso
    5284 !          write(*,*) 'delt*conversion=',delt*conversion(iso_eau)
    5285 !           write(*,*) 'delt*fxtYe=',delt*fxtYe(iso_eau)
    5286 !           write(*,*) 'delt*fxtqe=',delt*fxtqe(iso_eau) 
    5287         endif !if (option_traceurs.eq.6) then
    5288 #endif       
     5267!          WRITE(*,*) 'delt*conversion=',delt*conversion(iso_eau)
     5268!           WRITE(*,*) 'delt*fxtYe=',delt*fxtYe(iso_eau)
     5269!           WRITE(*,*) 'delt*fxtqe=',delt*fxtqe(iso_eau)
     5270        endif !if (option_traceurs.EQ.6) THEN
     5271#endif
    52895272
    52905273#ifdef DIAGISO
    52915274        fq_evapprecip(il,i)=fq_evapprecip(il,i) &
    5292      &           +0.5*sigd*(evap(il,i)+evap(il,i+1))
     5275                 +0.5*sigd*(evap(il,i)+evap(il,i+1))
    52935276        fq_ddft(il,i)=fq_ddft(il,i) &
    5294      &        +0.1*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i) &
    5295      &               *(rp(il,i)-rr(il,i-1)))*dpinv
    5296        do ixt = 1, niso
     5277              +0.1*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i) &
     5278                     *(rp(il,i)-rr(il,i-1)))*dpinv
     5279       DO ixt = 1, niso
    52975280        fxt_evapprecip(ixt,il,i)=fxt_evapprecip(ixt,il,i) &
    5298      &   +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
     5281         +0.5*sigd*(xtevap(ixt,il,i)+xtevap(ixt,il,i+1))
    52995282        fxt_ddft(ixt,il,i)=fxt_ddft(ixt,il,i) &
    5300      &   +0.1*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
    5301      &        -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
    5302        enddo ! ixt=1,niso 
    5303 #endif     
     5283         +0.1*(mp(il,i+1)*(xtp(ixt,il,i+1)-xt(ixt,il,i)) &
     5284              -mp(il,i)*(xtp(ixt,il,i)-xt(ixt,il,i-1)))*dpinv
     5285       enddo ! ixt=1,niso
     5286#endif
    53045287
    53055288        ! cam verif
    53065289
    53075290#ifdef ISOVERIF
    5308        do ixt=1,niso
    5309         call iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 5083')
     5291       DO ixt=1,niso
     5292        CALL iso_verif_noNaN(fxt(ixt,il,i),'cv30_yield 5083')
    53105293       enddo
    5311 #endif       
    5312 #ifdef ISOVERIF
    5313           if (iso_eau.gt.0) then
    5314               call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
    5315      &           fr(il,i),'cv30_routines 3522',errmax,errmaxrel)
    5316           endif !if (iso_eau.gt.0) then
    5317           if ((iso_HDO.gt.0).and.(delt*fr(il,i).gt.ridicule)) then
    5318               if (iso_verif_aberrant_enc_nostop( &
    5319      &           fxt(iso_HDO,il,i)/fr(il,i), &
    5320      &           'cv30_yield 3690').eq.1) then
    5321                 write(*,*) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
     5294#endif
     5295#ifdef ISOVERIF
     5296          IF (iso_eau.gt.0) THEN
     5297              CALL iso_verif_egalite_choix(fxt(iso_eau,il,i), &
     5298                 fr(il,i),'cv30_routines 3522',errmax,errmaxrel)
     5299          endif !if (iso_eau.gt.0) THEN
     5300          IF ((iso_HDO.gt.0).AND.(delt*fr(il,i).gt.ridicule)) THEN
     5301              IF (iso_verif_aberrant_enc_nostop( &
     5302                 fxt(iso_HDO,il,i)/fr(il,i), &
     5303                 'cv30_yield 3690').EQ.1) THEN
     5304                WRITE(*,*) 'i,icb(il),inb(il)=',i,icb(il),inb(il)
    53225305                stop
    53235306               endif
    5324           endif !if (iso_HDO.gt.0) then
    5325           if ((iso_HDO.gt.0).and. &
    5326      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    5327            call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
    5328      &                   +delt*fxt(iso_HDO,il,i)) &
    5329      &          /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3757b, ddfts')
    5330           endif !if (iso_HDO.gt.0) then         
    5331           if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
    5332      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    5333            call iso_verif_O18_aberrant( &
    5334      &           (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
    5335      &           (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
    5336      &           'cv30_yield 3757b,O18, ddfts')
    5337           endif !if (iso_HDO.gt.0) then     
     5307          endif !if (iso_HDO.gt.0) THEN
     5308          IF ((iso_HDO.gt.0).AND. &
     5309                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     5310           CALL iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
     5311                         +delt*fxt(iso_HDO,il,i)) &
     5312                /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3757b, ddfts')
     5313          endif !if (iso_HDO.gt.0) THEN
     5314          IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0).AND. &
     5315                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     5316           CALL iso_verif_O18_aberrant( &
     5317                 (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
     5318                 (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
     5319                 'cv30_yield 3757b,O18, ddfts')
     5320          endif !if (iso_HDO.gt.0) THEN
    53385321#ifdef ISOTRAC
    5339         call iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 4172')
    5340         do ixt=1,ntraciso
     5322        CALL iso_verif_traceur_justmass(fxt(1,il,i),'cv30_routine 4172')
     5323        DO ixt=1,ntraciso
    53415324          xtnew(ixt)=xt(ixt,il,1)+delt*fxt(ixt,il,1)
    53425325        enddo
    5343         if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4295',1e-5) &
    5344      &           .eq.1) then
    5345               write(*,*) 'il,i=',il,i 
     5326        IF (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4295',1e-5) &
     5327                 .EQ.1) THEN
     5328              WRITE(*,*) 'il,i=',il,i
    53465329         endif
    5347 !        call iso_verif_tracpos_choix(xtnew,'cv30_yield 4295',1e-5)
    5348 #endif           
    5349 #endif
    5350        ! end cam verif 
     5330!        CALL iso_verif_tracpos_choix(xtnew,'cv30_yield 4295',1e-5)
     5331#endif
     5332#endif
     5333       ! end cam verif
    53515334#endif
    53525335
    … …  
    53845367    ! do j=1,ntra
    53855368    ! do il=1,ncum
    5386     ! if (i.le.inb(il)) then
     5369    ! if (i.le.inb(il)) THEN
    53875370    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
    53885371    ! cpinv=1.0/cpn(il,i)
    53895372
    5390     ! if (cvflag_grav) then
     5373    ! if (cvflag_grav) THEN
    53915374    ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
    53925375    ! :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
    … …  
    53965379    ! :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
    53975380    ! :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
    5398     ! endif
    5399     ! endif ! i
     5381    ! END IF
     5382    ! END IF ! i
    54005383    ! enddo
    54015384    ! enddo
    … …  
    54115394
    54125395! attention, on corrige un probleme C Risi
    5413       IF (cvflag_grav) then
    5414 
     5396      IF (cvflag_grav) THEN
    54155397       ax = 0.01*grav*ment(il, inb(il), inb(il))*(hp(il,inb(il))-h(il,inb(il))+t(il, &
    54165398      inb(il))*(cpv-cpd)*(rr(il,inb(il))-qent(il,inb(il), &
    … …  
    54395421      1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
    54405422
    5441      
    5442 #ifdef ISO
    5443       do ixt = 1, ntraciso
     5423
     5424#ifdef ISO
     5425      DO ixt = 1, ntraciso
    54445426       xtbx(ixt)=0.01*grav*ment(il,inb(il),inb(il)) &
    5445      &    *(xtent(ixt,il,inb(il),inb(il)) &
    5446      &    -xt(ixt,il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
     5427          *(xtent(ixt,il,inb(il),inb(il)) &
     5428          -xt(ixt,il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
    54475429       fxt(ixt,il,inb(il))=fxt(ixt,il,inb(il))-xtbx(ixt)
    54485430       fxt(ixt,il,inb(il)-1)=fxt(ixt,il,inb(il)-1) &
    5449      &   +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
    5450      &      /(ph(il,inb(il)-1)-ph(il,inb(il)))
     5431         +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
     5432            /(ph(il,inb(il)-1)-ph(il,inb(il)))
    54515433      enddo !do ixt = 1, niso
    5452 #endif   
     5434#endif
    54535435
    54545436      else !IF (cvflag_grav)
    … …  
    54805462
    54815463
    5482      
    5483 #ifdef ISO
    5484       do ixt = 1, ntraciso
     5464
     5465#ifdef ISO
     5466      DO ixt = 1, ntraciso
    54855467       xtbx(ixt)=0.1*ment(il,inb(il),inb(il)) &
    5486      &    *(xtent(ixt,il,inb(il),inb(il)) &
    5487      &    -xt(ixt,il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
     5468          *(xtent(ixt,il,inb(il),inb(il)) &
     5469          -xt(ixt,il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
    54885470       fxt(ixt,il,inb(il))=fxt(ixt,il,inb(il))-xtbx(ixt)
    54895471       fxt(ixt,il,inb(il)-1)=fxt(ixt,il,inb(il)-1) &
    5490      &   +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
    5491      &      /(ph(il,inb(il)-1)-ph(il,inb(il)))
     5472         +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
     5473            /(ph(il,inb(il)-1)-ph(il,inb(il)))
    54925474      enddo !do ixt = 1, niso
    5493 #endif     
     5475#endif
    54945476
    54955477      endif  !IF (cvflag_grav)
    … …  
    55005482       fq_detrainement(il,inb(il))=fq_detrainement(il,inb(il))-bx
    55015483       fq_detrainement(il,inb(il)-1)=fq_detrainement(il,inb(il)-1) &
    5502      &   +bx*(ph(il,inb(il))-ph(il,inb(il)+1)) &
    5503      &      /(ph(il,inb(il)-1)-ph(il,inb(il)))
    5504        do ixt = 1, niso
     5484         +bx*(ph(il,inb(il))-ph(il,inb(il)+1)) &
     5485            /(ph(il,inb(il)-1)-ph(il,inb(il)))
     5486       DO ixt = 1, niso
    55055487        fxt_detrainement(ixt,il,inb(il))= &
    5506      &           fxt_detrainement(ixt,il,inb(il))-xtbx(ixt)
     5488                 fxt_detrainement(ixt,il,inb(il))-xtbx(ixt)
    55075489        fxt_detrainement(ixt,il,inb(il)-1)= &
    5508      &           fxt_detrainement(ixt,il,inb(il)-1) &
    5509      &           +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
    5510      &           /(ph(il,inb(il)-1)-ph(il,inb(il)))
     5490                 fxt_detrainement(ixt,il,inb(il)-1) &
     5491                 +xtbx(ixt)*(ph(il,inb(il))-ph(il,inb(il)+1)) &
     5492                 /(ph(il,inb(il)-1)-ph(il,inb(il)))
    55115493       enddo
    55125494#endif
    55135495      ! cam verif
    55145496#ifdef ISOVERIF
    5515        do ixt=1,niso
    5516         call iso_verif_noNaN(fxt(ixt,il,inb(il)),'cv30_yield 5083')
     5497       DO ixt=1,niso
     5498        CALL iso_verif_noNaN(fxt(ixt,il,inb(il)),'cv30_yield 5083')
    55175499       enddo
    5518           if (iso_eau.gt.0) then
    5519               call iso_verif_egalite_choix(fxt(iso_eau,il,inb(il)), &
    5520      &           fr(il,inb(il)),'cv30_routines 3638',errmax,errmaxrel)
    5521               call iso_verif_egalite_choix(fxt(iso_eau,il,inb(il)-1), &
    5522      &           fr(il,inb(il)-1),'cv30_routines 3640',errmax,errmaxrel)
    5523           endif !if (iso_eau.gt.0) then
    5524           if ((iso_HDO.gt.0).and. &
    5525      &       (rr(il,inb(il))+delt*fr(il,inb(il)).gt.ridicule)) then
    5526            call iso_verif_aberrant_encadre( &
    5527      &           (xt(iso_HDO,il,inb(il))+delt*fxt(iso_HDO,il,inb(il))) &
    5528      &         /(rr(il,inb(il))+delt*fr(il,inb(il))), &
    5529      &           'cv30_yield 3921, en inb')
    5530               if (iso_O18.gt.0) then               
    5531                 if (iso_verif_O18_aberrant_nostop( &
    5532      &           (xt(iso_HDO,il,inb(il))+delt*fxt(iso_HDO,il,inb(il))) &
    5533      &           /(rr(il,inb(il))+delt*fr(il,inb(il))), &
    5534      &           (xt(iso_O18,il,inb(il))+delt*fxt(iso_O18,il,inb(il))) &
    5535      &           /(rr(il,inb(il))+delt*fr(il,inb(il))), &
    5536      &           'cv30_yield 3921O18, en inb').eq.1) then
    5537                         write(*,*) 'il,inb(il)=',il,inb(il)
     5500          IF (iso_eau.gt.0) THEN
     5501              CALL iso_verif_egalite_choix(fxt(iso_eau,il,inb(il)), &
     5502                 fr(il,inb(il)),'cv30_routines 3638',errmax,errmaxrel)
     5503              CALL iso_verif_egalite_choix(fxt(iso_eau,il,inb(il)-1), &
     5504                 fr(il,inb(il)-1),'cv30_routines 3640',errmax,errmaxrel)
     5505          endif !if (iso_eau.gt.0) THEN
     5506          IF ((iso_HDO.gt.0).AND. &
     5507             (rr(il,inb(il))+delt*fr(il,inb(il)).gt.ridicule)) THEN
     5508           CALL iso_verif_aberrant_encadre( &
     5509                 (xt(iso_HDO,il,inb(il))+delt*fxt(iso_HDO,il,inb(il))) &
     5510               /(rr(il,inb(il))+delt*fr(il,inb(il))), &
     5511                 'cv30_yield 3921, en inb')
     5512              IF (iso_O18.gt.0) THEN
     5513                IF (iso_verif_O18_aberrant_nostop( &
     5514                 (xt(iso_HDO,il,inb(il))+delt*fxt(iso_HDO,il,inb(il))) &
     5515                 /(rr(il,inb(il))+delt*fr(il,inb(il))), &
     5516                 (xt(iso_O18,il,inb(il))+delt*fxt(iso_O18,il,inb(il))) &
     5517                 /(rr(il,inb(il))+delt*fr(il,inb(il))), &
     5518                 'cv30_yield 3921O18, en inb').EQ.1) THEN
     5519                        WRITE(*,*) 'il,inb(il)=',il,inb(il)
    55385520                        k_tmp=0.1*ment(il,inb(il),inb(il))/(ph(il,inb(il))-ph(il,inb(il)+1))
    5539                         write(*,*) 'fr,frprec=',fr(il,inb(il)),fr(il,inb(il))+bx
    5540                         write(*,*) 'M,dt,k_tmp*dt=',k_tmp,delt,k_tmp*delt
    5541                         write(*,*) 'q,qe=',rr(il,inb(il)),qent(il,inb(il),inb(il))
    5542                         write(*,*) 'r=',k_tmp*delt*qent(il,inb(il),inb(il))/rr(il,inb(il))
    5543                         write(*,*) 'deltaDR,Re=',deltaD(xt(iso_HDO,il,inb(il))/rr(il,inb(il))), &
    5544                         &       deltaD(xtent(iso_HDO,il,inb(il),inb(il))/qent(il,inb(il),inb(il)))
    5545                         write(*,*) 'deltaO18R,Re=',deltaO(xt(iso_O18,il,inb(il))/rr(il,inb(il))), &
    5546                         &       deltaO(xtent(iso_O18,il,inb(il),inb(il))/qent(il,inb(il),inb(il)))       
     5521                        WRITE(*,*) 'fr,frprec=',fr(il,inb(il)),fr(il,inb(il))+bx
     5522                        WRITE(*,*) 'M,dt,k_tmp*dt=',k_tmp,delt,k_tmp*delt
     5523                        WRITE(*,*) 'q,qe=',rr(il,inb(il)),qent(il,inb(il),inb(il))
     5524                        WRITE(*,*) 'r=',k_tmp*delt*qent(il,inb(il),inb(il))/rr(il,inb(il))
     5525                        WRITE(*,*) 'deltaDR,Re=',deltaD(xt(iso_HDO,il,inb(il))/rr(il,inb(il))), &
     5526                                deltaD(xtent(iso_HDO,il,inb(il),inb(il))/qent(il,inb(il),inb(il)))
     5527                        WRITE(*,*) 'deltaO18R,Re=',deltaO(xt(iso_O18,il,inb(il))/rr(il,inb(il))), &
     5528                                deltaO(xtent(iso_O18,il,inb(il),inb(il))/qent(il,inb(il),inb(il)))
    55475529                stop
    55485530              endif !if (iso_verif_O18_aberrant_nostop
    5549             endif !if (iso_O18.gt.0) then
    5550           endif !if (iso_HDO.gt.0) then
    5551           if ((iso_HDO.gt.0).and. &
    5552      &       (rr(il,inb(il)-1)+delt*fr(il,inb(il)-1).gt.ridicule)) then
    5553            call iso_verif_aberrant_encadre( &
    5554      &           (xt(iso_HDO,il,inb(il)-1) &
    5555      &           +delt*fxt(iso_HDO,il,inb(il)-1)) &
    5556      &         /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
    5557      &           'cv30_yield 3921b, en inb-1')
    5558               if (iso_O18.gt.0) then               
    5559                 call iso_verif_O18_aberrant( &
    5560      &           (xt(iso_HDO,il,inb(il)-1)+delt*fxt(iso_HDO,il,inb(il)-1)) &
    5561      &           /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
    5562      &           (xt(iso_O18,il,inb(il)-1)+delt*fxt(iso_O18,il,inb(il)-1)) &
    5563      &           /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
    5564      &           'cv30_yield 3921cO18, en inb-1')
     5531            endif !if (iso_O18.gt.0) THEN
     5532          endif !if (iso_HDO.gt.0) THEN
     5533          IF ((iso_HDO.gt.0).AND. &
     5534             (rr(il,inb(il)-1)+delt*fr(il,inb(il)-1).gt.ridicule)) THEN
     5535           CALL iso_verif_aberrant_encadre( &
     5536                 (xt(iso_HDO,il,inb(il)-1) &
     5537                 +delt*fxt(iso_HDO,il,inb(il)-1)) &
     5538               /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
     5539                 'cv30_yield 3921b, en inb-1')
     5540              IF (iso_O18.gt.0) THEN
     5541                CALL iso_verif_O18_aberrant( &
     5542                 (xt(iso_HDO,il,inb(il)-1)+delt*fxt(iso_HDO,il,inb(il)-1)) &
     5543                 /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
     5544                 (xt(iso_O18,il,inb(il)-1)+delt*fxt(iso_O18,il,inb(il)-1)) &
     5545                 /(rr(il,inb(il)-1)+delt*fr(il,inb(il)-1)), &
     5546                 'cv30_yield 3921cO18, en inb-1')
    55655547              endif
    5566           endif !if (iso_HDO.gt.0) then
     5548          endif !if (iso_HDO.gt.0) THEN
    55675549#ifdef ISOTRAC
    5568         call iso_verif_traceur_justmass(fxt(1,il,inb(il)-1), &
    5569      &           'cv30_routine 4364')
    5570         call iso_verif_traceur_justmass(fxt(1,il,inb(il)), &
    5571      &           'cv30_routine 4364b')
    5572         do ixt=1,ntraciso
     5550        CALL iso_verif_traceur_justmass(fxt(1,il,inb(il)-1), &
     5551                 'cv30_routine 4364')
     5552        CALL iso_verif_traceur_justmass(fxt(1,il,inb(il)), &
     5553                 'cv30_routine 4364b')
     5554        DO ixt=1,ntraciso
    55735555          xtnew(ixt)=xt(ixt,il,inb(il))+delt*fxt(ixt,il,inb(il))
    55745556        enddo
    5575         if (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4492',1e-5) &
    5576      &           .eq.1) then
    5577               write(*,*) 'il,i=',il,i 
     5557        IF (iso_verif_tracpos_choix_nostop(xtnew,'cv30_yield 4492',1e-5) &
     5558                 .EQ.1) THEN
     5559              WRITE(*,*) 'il,i=',il,i
    55785560         endif
    5579 !        call iso_verif_tracpos_choix(xtnew,'cv30_yield 4492',1e-5)
    5580 #endif           
    5581 #endif
    5582       ! end cam verif 
     5561!        CALL iso_verif_tracpos_choix(xtnew,'cv30_yield 4492',1e-5)
     5562#endif
     5563#endif
     5564      ! end cam verif
    55835565#endif
    55845566
    … …  
    56085590#ifdef ISO
    56095591        frsum(il)=0.0
    5610         do ixt=1,ntraciso
     5592        DO ixt=1,ntraciso
    56115593          fxtsum(ixt,il)=0.0
    56125594          bxtsum(ixt,il)=0.0
    … …  
    56255607        dsum(il) = dsum(il) + t(il, i)*(ph(il,i)-ph(il,i+1))/th(il, i)
    56265608#ifdef ISO
    5627        
     5609
    56285610      frsum(il)=frsum(il)+fr(il,i)
    5629       do ixt=1,ntraciso
     5611      DO ixt=1,ntraciso
    56305612        fxtsum(ixt,il)=fxtsum(ixt,il)+fxt(ixt,il,i)
    56315613        bxtsum(ixt,il)=bxtsum(ixt,il)+fxt(ixt,il,i) &
    5632      &           *(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1))) &
    5633      &                  *(ph(il,i)-ph(il,i+1))
    5634       enddo 
     5614                 *(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1))) &
     5615                        *(ph(il,i)-ph(il,i+1))
     5616      enddo
    56355617#endif
    56365618      END IF
    … …  
    56455627        fr(il, i) = bsum(il)/csum(il)
    56465628#ifdef ISO
    5647         if (abs(csum(il)).gt.0.0) then
    5648           do ixt=1,ntraciso
    5649             fxt(ixt,il,i)=bxtsum(ixt,il)/csum(il)           
     5629        IF (abs(csum(il)).gt.0.0) THEN
     5630          DO ixt=1,ntraciso
     5631            fxt(ixt,il,i)=bxtsum(ixt,il)/csum(il)
    56505632          enddo
    5651         else !if (frsum(il).gt.ridicule) then
    5652            if (abs(frsum(il)).gt.0.0) then
    5653             do ixt=1,ntraciso
    5654              fxt(ixt,il,i)=fr(il,i)*fxtsum(ixt,il)/frsum(il)       
    5655             enddo 
    5656            else !if (abs(frsum(il)).gt.0.0) then
    5657              if (abs(fr(il,i))*delt.gt.ridicule) then
    5658                write(*,*) 'cv30_yield 4048: fr(il,i)=',fr(il,i)
    5659                stop 
    5660              else !if (abs(fr(il,i))*delt.gt.ridicule) then
    5661                do ixt=1,ntraciso
     5633        else !if (frsum(il).gt.ridicule) THEN
     5634           IF (abs(frsum(il)).gt.0.0) THEN
     5635            DO ixt=1,ntraciso
     5636             fxt(ixt,il,i)=fr(il,i)*fxtsum(ixt,il)/frsum(il)
     5637            enddo
     5638           else !if (abs(frsum(il)).gt.0.0) THEN
     5639             IF (abs(fr(il,i))*delt.gt.ridicule) THEN
     5640               WRITE(*,*) 'cv30_yield 4048: fr(il,i)=',fr(il,i)
     5641               stop
     5642             else !if (abs(fr(il,i))*delt.gt.ridicule) THEN
     5643               DO ixt=1,ntraciso
    56625644                 fxt(ixt,il,i)=0.0
    56635645               enddo
    5664                if (iso_eau.gt.0) then
     5646               IF (iso_eau.gt.0) THEN
    56655647                   fxt(iso_eau,il,i)=1.0
    56665648               endif
    5667              endif !if (abs(fr(il,i))*delt.gt.ridicule) then
    5668            endif !if (abs(frsum(il)).gt.0.0) then
    5669          endif !if (frsum(il).gt.0) then
     5649             endif !if (abs(fr(il,i))*delt.gt.ridicule) THEN
     5650           endif !if (abs(frsum(il)).gt.0.0) THEN
     5651         endif !if (frsum(il).gt.0) THEN
    56705652#endif
    56715653      END IF
    … …  
    56765658#ifdef ISO
    56775659#ifdef ISOVERIF
    5678         do i=1,nl
    5679           do il=1,ncum
    5680            do ixt=1,ntraciso
    5681             call iso_verif_noNAN(fxt(ixt,il,i),'cv30_yield 3826')     
     5660        DO i=1,nl
     5661          DO il=1,ncum
     5662           DO ixt=1,ntraciso
     5663            CALL iso_verif_noNAN(fxt(ixt,il,i),'cv30_yield 3826')
    56825664           enddo
    56835665          enddo
    56845666        enddo
    5685 #endif               
    5686 #ifdef ISOVERIF
    5687           do i=1,nl
    5688 !             write(*,*) 'cv30_routines temp 3967: i=',i
    5689              do il=1,ncum
    5690 !                write(*,*) 'cv30_routines 3969: il=',il
    5691 !                write(*,*) 'cv30_routines temp 3967: il,i,inb(il),ncum=',
     5667#endif
     5668#ifdef ISOVERIF
     5669          DO i=1,nl
     5670!             WRITE(*,*) 'cv30_routines temp 3967: i=',i
     5671             DO il=1,ncum
     5672!                WRITE(*,*) 'cv30_routines 3969: il=',il
     5673!                WRITE(*,*) 'cv30_routines temp 3967: il,i,inb(il),ncum=',
    56925674!     :                           il,i,inb(il),ncum
    5693 !                write(*,*) 'cv30_routines 3974'
    5694                 if (iso_eau.gt.0) then
    5695                   call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
    5696      &              fr(il,i),'cv30_yield 3830',errmax,errmaxrel) 
    5697                 endif !if (iso_eau.gt.0) then
    5698 !                write(*,*) 'cv30_routines 3979'
    5699                 if ((iso_HDO.gt.0).and. &
    5700      &              (delt*fr(il,i).gt.ridicule)) then
    5701                     if (iso_verif_aberrant_enc_nostop( &
    5702      &                   fxt(iso_HDO,il,i)/fr(il,i), &
    5703      &                  'cv30_yield 3834').eq.1) then                       
    5704                         if (fr(il,i).gt.ridicule*1e5) then
    5705                            write(*,*) 'il,i,icb(il)=',il,i,icb(il)
    5706                            write(*,*) 'frsum(il)=',frsum(il)
    5707                            write(*,*) 'fr(il,i)=',fr(il,i) 
    5708                            write(*,*) 'csum(il)=',csum(il) 
    5709                            write(*,*) &
    5710      &                          'deltaD(bxtsum(iso_HDO,il)/csum(il))=', &
    5711      &                         deltaD(bxtsum(iso_HDO,il)/csum(il))                             
     5675!                WRITE(*,*) 'cv30_routines 3974'
     5676                IF (iso_eau.gt.0) THEN
     5677                  CALL iso_verif_egalite_choix(fxt(iso_eau,il,i), &
     5678                    fr(il,i),'cv30_yield 3830',errmax,errmaxrel)
     5679                endif !if (iso_eau.gt.0) THEN
     5680!                WRITE(*,*) 'cv30_routines 3979'
     5681                IF ((iso_HDO.gt.0).AND. &
     5682                    (delt*fr(il,i).gt.ridicule)) THEN
     5683                    IF (iso_verif_aberrant_enc_nostop( &
     5684                         fxt(iso_HDO,il,i)/fr(il,i), &
     5685                        'cv30_yield 3834').EQ.1) THEN
     5686                        IF (fr(il,i).gt.ridicule*1e5) THEN
     5687                           WRITE(*,*) 'il,i,icb(il)=',il,i,icb(il)
     5688                           WRITE(*,*) 'frsum(il)=',frsum(il)
     5689                           WRITE(*,*) 'fr(il,i)=',fr(il,i)
     5690                           WRITE(*,*) 'csum(il)=',csum(il)
     5691                           WRITE(*,*) &
     5692                                'deltaD(bxtsum(iso_HDO,il)/csum(il))=', &
     5693                               deltaD(bxtsum(iso_HDO,il)/csum(il))
    57125694!                           stop
    57135695                        endif
    5714 !                        write(*,*) 'cv30_routines 3986: temporaire'
    5715                     endif   !if (iso_verif_aberrant_enc_nostop   
    5716                 endif !if (iso_HDO.gt.0) then
    5717                 if ((iso_HDO.gt.0).and. &
    5718      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    5719                   if (iso_verif_aberrant_enc_nostop( &
    5720      &          (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
    5721      &         /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3921c, dans la CL') &
    5722      &           .eq.1) then
    5723                      write(*,*) 'il,i,icb(il)=',il,i,icb(il)
    5724                      write(*,*) 'frsum(il)=',frsum(il)
    5725                      write(*,*) 'fr(il,i)=',fr(il,i)   
     5696!                        WRITE(*,*) 'cv30_routines 3986: temporaire'
     5697                    endif   !if (iso_verif_aberrant_enc_nostop
     5698                endif !if (iso_HDO.gt.0) THEN
     5699                IF ((iso_HDO.gt.0).AND. &
     5700                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     5701                  IF (iso_verif_aberrant_enc_nostop( &
     5702                (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i)) &
     5703               /(rr(il,i)+delt*fr(il,i)),'cv30_yield 3921c, dans la CL') &
     5704                 .EQ.1) THEN
     5705                     WRITE(*,*) 'il,i,icb(il)=',il,i,icb(il)
     5706                     WRITE(*,*) 'frsum(il)=',frsum(il)
     5707                     WRITE(*,*) 'fr(il,i)=',fr(il,i)
    57265708                     stop
    57275709                  endif
    5728                endif !if (iso_HDO.gt.0) then
    5729                
    5730         if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
    5731      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    5732          call iso_verif_O18_aberrant( &
    5733      &           (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
    5734      &           (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
    5735      &           'cv30_yield 3921d, dans la CL')
    5736         endif !if (iso_HDO.gt.0) then
     5710               endif !if (iso_HDO.gt.0) THEN
     5711        IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0).AND. &
     5712                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     5713         CALL iso_verif_O18_aberrant( &
     5714                 (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
     5715                 (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
     5716                 'cv30_yield 3921d, dans la CL')
     5717        endif !if (iso_HDO.gt.0) THEN
    57375718#ifdef ISOTRAC
    5738                 call iso_verif_traceur_justmass(fxt(1,il,i), &
    5739      &                  'cv30_routine 4523')
    5740 #endif                 
    5741 !                write(*,*) 'cv30_routines 3994'
     5719                CALL iso_verif_traceur_justmass(fxt(1,il,i), &
     5720                        'cv30_routine 4523')
     5721#endif
     5722!                WRITE(*,*) 'cv30_routines 3994'
    57425723             enddo !do il=1,ncum
    5743 !             write(*,*) 'cv30_routine 3990: fin des il pour i=',i
     5724!             WRITE(*,*) 'cv30_routine 3990: fin des il pour i=',i
    57445725          enddo !do i=1,nl
    5745 !          write(*,*) 'cv30_routine 3990: fin des verifs sur homogen'
     5726!          WRITE(*,*) 'cv30_routine 3990: fin des verifs sur homogen'
    57465727#endif
    57475728
    57485729#ifdef ISOVERIF
    57495730        ! verif finale des tendances:
    5750           do i=1,nl
    5751              do il=1,ncum
    5752                 if (iso_eau.gt.0) then
    5753                   call iso_verif_egalite_choix(fxt(iso_eau,il,i), &
    5754      &              fr(il,i),'cv30_yield 3830',errmax,errmaxrel) 
    5755                 endif !if (iso_eau.gt.0) then
    5756                 if ((iso_HDO.gt.0).and. &
    5757      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    5758                   call iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
    5759      &                   +delt*fxt(iso_HDO,il,i)) &
    5760      &           /(rr(il,i)+delt*fr(il,i)), &
    5761      &           'cv30_yield 5710a, final')
    5762                endif !if (iso_HDO.gt.0) then               
    5763                if ((iso_HDO.gt.0).and.(iso_O18.gt.0).and. &
    5764      &           (rr(il,i)+delt*fr(il,i).gt.ridicule)) then
    5765                   call iso_verif_O18_aberrant( &
    5766      &           (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
    5767      &           (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
    5768      &           'cv30_yield 5710b, final')
    5769                endif !if (iso_HDO.gt.0) then
     5731          DO i=1,nl
     5732             DO il=1,ncum
     5733                IF (iso_eau.gt.0) THEN
     5734                  CALL iso_verif_egalite_choix(fxt(iso_eau,il,i), &
     5735                    fr(il,i),'cv30_yield 3830',errmax,errmaxrel)
     5736                endif !if (iso_eau.gt.0) THEN
     5737                IF ((iso_HDO.gt.0).AND. &
     5738                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     5739                  CALL iso_verif_aberrant_encadre((xt(iso_HDO,il,i) &
     5740                         +delt*fxt(iso_HDO,il,i)) &
     5741                 /(rr(il,i)+delt*fr(il,i)), &
     5742                 'cv30_yield 5710a, final')
     5743               endif !if (iso_HDO.gt.0) THEN
     5744               IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0).AND. &
     5745                 (rr(il,i)+delt*fr(il,i).gt.ridicule)) THEN
     5746                  CALL iso_verif_O18_aberrant( &
     5747                 (xt(iso_HDO,il,i)+delt*fxt(iso_HDO,il,i))/(rr(il,i)+delt*fr(il,i)), &
     5748                 (xt(iso_O18,il,i)+delt*fxt(iso_O18,il,i))/(rr(il,i)+delt*fr(il,i)), &
     5749                 'cv30_yield 5710b, final')
     5750               endif !if (iso_HDO.gt.0) THEN
    57705751             enddo !do il=1,ncum
    57715752          enddo !do i=1,nl
    … …  
    58355816    DO k = i, nl
    58365817      DO il = 1, ncum
    5837         ! test         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il))
    5838         ! then
     5818        ! test         if (i.ge.icb(il).AND.i.le.inb(il).AND.k.le.inb(il))
     5819        ! THEN
    58395820        IF (i<=inb(il) .AND. k<=inb(il)) THEN
    58405821          upwd(il, i) = upwd(il, i) + m(il, k) + up1(il, k, i)
    … …  
    59335914  ! *** diagnose the in-cloud mixing ratio   ***            ! cld
    59345915  ! ***           of condensed water         ***            ! cld
    5935   ! ! cld
     5916  ! cld
    59365917
    59375918  DO i = 1, nd ! cld
    … …  
    59925973  END DO ! cld
    59935974
    5994   RETURN
     5975
    59955976END SUBROUTINE cv30_yield
    59965977
    5997 ! !RomP >>>
     5978!RomP >>>
    59985979SUBROUTINE cv30_tracer(nloc, len, ncum, nd, na, ment, sij, da, phi, phi2, &
    59995980    d1a, dam, ep, vprecip, elij, clw, epmlmmm, eplamm, icb, inb)
    60005981  IMPLICIT NONE
    60015982
    6002   include "cv30param.h"
     5983
    60035984
    60045985  ! inputs:
    … …  
    60536034      DO i = 1, ncum
    60546035        IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
    6055           ! !jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
     6036          !jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
    60566037          epm(i, j, k) = 1. - (1.-ep(i,j))*clw(i, j)/max(elij(i,k,j), 1.E-16)
    6057           ! !
     6038
    60586039          epm(i, j, k) = max(epm(i,j,k), 0.0)
    60596040        END IF
    … …  
    61046085  END DO
    61056086
    6106   RETURN
     6087
    61076088END SUBROUTINE cv30_tracer
    61086089! RomP <<<
    … …  
    61166097    elij1, clw1, epmlmmm1, eplamm1, wdtraina1, wdtrainm1,epmax_diag1 & ! epmax_cape
    61176098#ifdef ISO
    6118      &         ,xtprecip,fxt,xtVPrecip,xtevap,xtclw,xtwdtraina &
    6119      &         ,xtprecip1,fxt1,xtVPrecip1,xtevap1,xtclw1,xtwdtraina1 &
     6099               ,xtprecip,fxt,xtVPrecip,xtevap,xtclw,xtwdtraina &
     6100               ,xtprecip1,fxt1,xtVPrecip1,xtevap1,xtclw1,xtwdtraina1 &
    61206101#ifdef DIAGISO
    6121      &         , water,xtwater,qp,xtp &
    6122      &         , fq_detrainement,fq_ddft,fq_fluxmasse,fq_evapprecip &
    6123      &         , fxt_detrainement,fxt_ddft,fxt_fluxmasse, fxt_evapprecip &
    6124      &         , f_detrainement,q_detrainement,xt_detrainement &
    6125      &         , water1,xtwater1,qp1,xtp1 &
    6126      &         , fq_detrainement1,fq_ddft1,fq_fluxmasse1,fq_evapprecip1 &
    6127      &         , fxt_detrainement1,fxt_ddft1,fxt_fluxmasse1, fxt_evapprecip1 &
    6128      &         , f_detrainement1,q_detrainement1,xt_detrainement1 &
    6129 #endif         
    6130 #endif 
    6131      &         )
    6132 
    6133 #ifdef ISO
    6134     use infotrac_phy, ONLY: ntraciso=>ntiso
    6135 #ifdef ISOVERIF
    6136     use isotopes_verif_mod, ONLY: Tmin_verif,iso_verif_aberrant, &
     6102               , water,xtwater,qp,xtp &
     6103               , fq_detrainement,fq_ddft,fq_fluxmasse,fq_evapprecip &
     6104               , fxt_detrainement,fxt_ddft,fxt_fluxmasse, fxt_evapprecip &
     6105               , f_detrainement,q_detrainement,xt_detrainement &
     6106               , water1,xtwater1,qp1,xtp1 &
     6107               , fq_detrainement1,fq_ddft1,fq_fluxmasse1,fq_evapprecip1 &
     6108               , fxt_detrainement1,fxt_ddft1,fxt_fluxmasse1, fxt_evapprecip1 &
     6109               , f_detrainement1,q_detrainement1,xt_detrainement1 &
     6110#endif
     6111#endif
     6112               )
     6113
     6114#ifdef ISO
     6115    USE infotrac_phy, ONLY: ntraciso=>ntiso
     6116#ifdef ISOVERIF
     6117    USE isotopes_verif_mod, ONLY: Tmin_verif,iso_verif_aberrant, &
    61376118        iso_verif_egalite,iso_verif_egalite_choix_nostop,iso_verif_positif_nostop, &
    61386119        iso_verif_egalite_nostop,iso_verif_aberrant_nostop,deltaD,iso_verif_noNaN_nostop, &
    … …  
    61426123  IMPLICIT NONE
    61436124
    6144   include "cv30param.h"
     6125
    61456126
    61466127  ! inputs:
    … …  
    61726153  REAL xtprecip(ntraciso,nloc)
    61736154  REAL xtvprecip(ntraciso,nloc, nd+1), xtevap(ntraciso,nloc, nd)
    6174   real fxt(ntraciso,nloc,nd)
    6175   real xtclw(ntraciso,nloc,nd)
     6155  REAL fxt(ntraciso,nloc,nd)
     6156  REAL xtclw(ntraciso,nloc,nd)
    61766157  REAL xtwdtraina(ntraciso,nloc, nd)
    61776158#endif
    … …  
    62016182  ! RomP <<<
    62026183#ifdef ISO
    6203   real xtprecip1(ntraciso,len)
    6204   real fxt1(ntraciso,len,nd)
    6205   real xtVPrecip1(ntraciso,len,nd+1),xtevap1(ntraciso,len, nd)
     6184  REAL xtprecip1(ntraciso,len)
     6185  REAL fxt1(ntraciso,len,nd)
     6186  REAL xtVPrecip1(ntraciso,len,nd+1),xtevap1(ntraciso,len, nd)
    62066187  REAL xtwdtraina1(ntraciso,len, nd)
    62076188  REAL xtclw1(ntraciso,len, nd)
    … …  
    62116192  INTEGER i, k, j
    62126193#ifdef ISO
    6213       integer ixt
     6194      INTEGER ixt
    62146195#endif
    62156196
    62166197#ifdef DIAGISO
    6217       real water(nloc,nd)
    6218       real xtwater(ntraciso,nloc,nd)
    6219       real qp(nloc,nd),xtp(ntraciso,nloc,nd)
    6220       real fq_detrainement(nloc,nd)
    6221       real f_detrainement(nloc,nd)
    6222       real q_detrainement(nloc,nd)
    6223       real fq_ddft(nloc,nd)
    6224       real fq_fluxmasse(nloc,nd)
    6225       real fq_evapprecip(nloc,nd)
    6226       real fxt_detrainement(ntraciso,nloc,nd)
    6227       real xt_detrainement(ntraciso,nloc,nd)
    6228       real fxt_ddft(ntraciso,nloc,nd)
    6229       real fxt_fluxmasse(ntraciso,nloc,nd)
    6230       real fxt_evapprecip(ntraciso,nloc,nd)
    6231 
    6232       real water1(len,nd)
    6233       real xtwater1(ntraciso,len,nd)
    6234       real qp1(len,nd),xtp1(ntraciso,len,nd)
    6235       real fq_detrainement1(len,nd)
    6236       real f_detrainement1(len,nd)
    6237       real q_detrainement1(len,nd)
    6238       real fq_ddft1(len,nd)
    6239       real fq_fluxmasse1(len,nd)
    6240       real fq_evapprecip1(len,nd)
    6241       real fxt_detrainement1(ntraciso,len,nd)
    6242       real xt_detrainement1(ntraciso,len,nd)
    6243       real fxt_ddft1(ntraciso,len,nd)
    6244       real fxt_fluxmasse1(ntraciso,len,nd)
    6245       real fxt_evapprecip1(ntraciso,len,nd)
    6246 #endif
    6247 
    6248 #ifdef ISOVERIF
    6249         write(*,*) 'cv30_routines 4293: entree dans cv3_uncompress'
     6198      REAL water(nloc,nd)
     6199      REAL xtwater(ntraciso,nloc,nd)
     6200      REAL qp(nloc,nd),xtp(ntraciso,nloc,nd)
     6201      REAL fq_detrainement(nloc,nd)
     6202      REAL f_detrainement(nloc,nd)
     6203      REAL q_detrainement(nloc,nd)
     6204      REAL fq_ddft(nloc,nd)
     6205      REAL fq_fluxmasse(nloc,nd)
     6206      REAL fq_evapprecip(nloc,nd)
     6207      REAL fxt_detrainement(ntraciso,nloc,nd)
     6208      REAL xt_detrainement(ntraciso,nloc,nd)
     6209      REAL fxt_ddft(ntraciso,nloc,nd)
     6210      REAL fxt_fluxmasse(ntraciso,nloc,nd)
     6211      REAL fxt_evapprecip(ntraciso,nloc,nd)
     6212
     6213      REAL water1(len,nd)
     6214      REAL xtwater1(ntraciso,len,nd)
     6215      REAL qp1(len,nd),xtp1(ntraciso,len,nd)
     6216      REAL fq_detrainement1(len,nd)
     6217      REAL f_detrainement1(len,nd)
     6218      REAL q_detrainement1(len,nd)
     6219      REAL fq_ddft1(len,nd)
     6220      REAL fq_fluxmasse1(len,nd)
     6221      REAL fq_evapprecip1(len,nd)
     6222      REAL fxt_detrainement1(ntraciso,len,nd)
     6223      REAL xt_detrainement1(ntraciso,len,nd)
     6224      REAL fxt_ddft1(ntraciso,len,nd)
     6225      REAL fxt_fluxmasse1(ntraciso,len,nd)
     6226      REAL fxt_evapprecip1(ntraciso,len,nd)
     6227#endif
     6228
     6229#ifdef ISOVERIF
     6230        WRITE(*,*) 'cv30_routines 4293: entree dans cv3_uncompress'
    62506231#endif
    62516232  DO i = 1, ncum
    … …  
    62576238    epmax_diag1(idcum(i))=epmax_diag(i) ! epmax_cape
    62586239#ifdef ISO
    6259          do ixt = 1, ntraciso
     6240         DO ixt = 1, ntraciso
    62606241          xtprecip1(ixt,idcum(i))=xtprecip(ixt,i)
    62616242         enddo
    … …  
    62906271      ! RomP <<<
    62916272#ifdef ISO
    6292             do ixt = 1, ntraciso
     6273            DO ixt = 1, ntraciso
    62936274             fxt1(ixt,idcum(i),k)=fxt(ixt,i,k)
    62946275             xtVPrecip1(ixt,idcum(i),k)=xtVPrecip(ixt,i,k)
    … …  
    63096290
    63106291#ifdef ISO
    6311 #ifdef DIAGISO 
    6312         do k=1,nl
    6313           do i=1,ncum   
     6292#ifdef DIAGISO
     6293        DO k=1,nl
     6294          DO i=1,ncum
    63146295            water1(idcum(i),k)=water(i,k)
    63156296            qp1(idcum(i),k)=qp(i,k)
    … …  
    63216302            fq_evapprecip1(idcum(i),k)=fq_evapprecip(i,k)
    63226303            fq_fluxmasse1(idcum(i),k)=fq_fluxmasse(i,k)
    6323             do ixt = 1, ntraciso
     6304            DO ixt = 1, ntraciso
    63246305             xtwater1(ixt,idcum(i),k)=xtwater(ixt,i,k)
    63256306             xtp1(ixt,idcum(i),k)=xtp(ixt,i,k)
    … …  
    63326313           enddo
    63336314         enddo
    6334          do i=1,ncum   
     6315         DO i=1,ncum
    63356316            epmax_diag1(idcum(i))=epmax_diag(i)
    63366317         enddo
    … …  
    63586339  END DO
    63596340
    6360   RETURN
     6341
    63616342END SUBROUTINE cv30_uncompress
    63626343
    6363         subroutine cv30_epmax_fn_cape(nloc,ncum,nd &
     6344        SUBROUTINE cv30_epmax_fn_cape(nloc,ncum,nd &
    63646345                ,cape,ep,hp,icb,inb,clw,nk,t,h,lv &
    63656346                ,epmax_diag)
    6366         USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    6367           , clmci, eps, epsi, epsim1, ginv, hrd, grav
    6368 implicit none
     6347        USE conema3_mod_h
     6348        USE cvthermo_mod_h
     6349
     6350        IMPLICIT NONE
    63696351
    63706352        ! On fait varier epmax en fn de la cape
    … …  
    63736355        ! Toutes les autres variables fn de ep sont calculees plus bas.
    63746356
    6375 INCLUDE "cv30param.h"
    6376 INCLUDE "conema3.h"
    6377 
    63786357! inputs:
    6379       integer ncum, nd, nloc
    6380       integer icb(nloc), inb(nloc)
    6381       real cape(nloc)
    6382       real clw(nloc,nd),lv(nloc,nd),t(nloc,nd),h(nloc,nd)
    6383       integer nk(nloc)
     6358      INTEGER ncum, nd, nloc
     6359      INTEGER icb(nloc), inb(nloc)
     6360      REAL cape(nloc)
     6361      REAL clw(nloc,nd),lv(nloc,nd),t(nloc,nd),h(nloc,nd)
     6362      INTEGER nk(nloc)
    63846363! inouts:
    6385       real ep(nloc,nd)
    6386       real hp(nloc,nd)
     6364      REAL ep(nloc,nd)
     6365      REAL hp(nloc,nd)
    63876366! outputs ou local
    6388       real epmax_diag(nloc)
     6367      REAL epmax_diag(nloc)
    63896368! locals
    6390       integer i,k   
    6391       real hp_bak(nloc,nd)
     6369      INTEGER i,k
     6370      REAL hp_bak(nloc,nd)
    63926371      CHARACTER (LEN=20) :: modname='cv30_epmax_fn_cape'
    63936372      CHARACTER (LEN=80) :: abort_message
    63946373
    63956374        ! on recalcule ep et hp
    6396        
    6397         if (coef_epmax_cape.gt.1e-12) then
    6398         do i=1,ncum
     6375
     6376        IF (coef_epmax_cape.gt.1e-12) THEN
     6377        DO i=1,ncum
    63996378           epmax_diag(i)=epmax-coef_epmax_cape*sqrt(cape(i))
    6400            do k=1,nl
     6379           DO k=1,nl
    64016380                ep(i,k)=ep(i,k)/epmax*epmax_diag(i)
    64026381                ep(i,k)=amax1(ep(i,k),0.0)
    … …  
    64066385
    64076386! On recalcule hp:
    6408       do k=1,nl
    6409         do i=1,ncum
    6410           hp_bak(i,k)=hp(i,k)
    6411         enddo
     6387      DO k=1,nl
     6388        DO i=1,ncum
     6389      hp_bak(i,k)=hp(i,k)
     6390    enddo
    64126391      enddo
    6413       do k=1,nlp
    6414         do i=1,ncum
    6415           hp(i,k)=h(i,k)
    6416         enddo
     6392      DO k=1,nlp
     6393        DO i=1,ncum
     6394      hp(i,k)=h(i,k)
     6395    enddo
    64176396      enddo
    6418       do k=minorig+1,nl
    6419        do i=1,ncum
    6420         if((k.ge.icb(i)).and.(k.le.inb(i)))then
     6397      DO k=minorig+1,nl
     6398       DO i=1,ncum
     6399        IF((k.ge.icb(i)).AND.(k.le.inb(i)))THEN
    64216400          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
    64226401        endif
    64236402       enddo
    64246403      enddo !do k=minorig+1,n
    6425 !     write(*,*) 'cv30_routines 6218: hp(1,20)=',hp(1,20)
    6426       do i=1,ncum 
    6427        do k=1,nl
    6428         if (abs(hp_bak(i,k)-hp(i,k)).gt.0.01) then
    6429            write(*,*) 'i,k=',i,k
    6430            write(*,*) 'coef_epmax_cape=',coef_epmax_cape
    6431            write(*,*) 'epmax_diag(i)=',epmax_diag(i)
    6432            write(*,*) 'ep(i,k)=',ep(i,k)
    6433            write(*,*) 'hp(i,k)=',hp(i,k)
    6434            write(*,*) 'hp_bak(i,k)=',hp_bak(i,k)
    6435            write(*,*) 'h(i,k)=',h(i,k)
    6436            write(*,*) 'nk(i)=',nk(i)
    6437            write(*,*) 'h(i,nk(i))=',h(i,nk(i))
    6438            write(*,*) 'lv(i,k)=',lv(i,k)
    6439            write(*,*) 't(i,k)=',t(i,k)
    6440            write(*,*) 'clw(i,k)=',clw(i,k)
    6441            write(*,*) 'cpd,cpv=',cpd,cpv
     6404!     WRITE(*,*) 'cv30_routines 6218: hp(1,20)=',hp(1,20)
     6405      DO i=1,ncum
     6406       DO k=1,nl
     6407        IF (abs(hp_bak(i,k)-hp(i,k)).gt.0.01) THEN
     6408           WRITE(*,*) 'i,k=',i,k
     6409           WRITE(*,*) 'coef_epmax_cape=',coef_epmax_cape
     6410           WRITE(*,*) 'epmax_diag(i)=',epmax_diag(i)
     6411           WRITE(*,*) 'ep(i,k)=',ep(i,k)
     6412           WRITE(*,*) 'hp(i,k)=',hp(i,k)
     6413           WRITE(*,*) 'hp_bak(i,k)=',hp_bak(i,k)
     6414           WRITE(*,*) 'h(i,k)=',h(i,k)
     6415           WRITE(*,*) 'nk(i)=',nk(i)
     6416           WRITE(*,*) 'h(i,nk(i))=',h(i,nk(i))
     6417           WRITE(*,*) 'lv(i,k)=',lv(i,k)
     6418           WRITE(*,*) 't(i,k)=',t(i,k)
     6419           WRITE(*,*) 'clw(i,k)=',clw(i,k)
     6420           WRITE(*,*) 'cpd,cpv=',cpd,cpv
    64426421           CALL abort_physic(modname,abort_message,0)
    64436422        endif
    64446423       enddo !do k=1,nl
    6445       enddo !do i=1,ncum 
    6446       endif !if (coef_epmax_cape.gt.1e-12) then
    6447 
    6448       return
    6449       end subroutine cv30_epmax_fn_cape
    6450 
    6451 
     6424      enddo !do i=1,ncum
     6425      endif !if (coef_epmax_cape.gt.1e-12) THEN
     6426      END SUBROUTINE  cv30_epmax_fn_cape
     6427
     6428
     6429
     6430
     6431
     6432
     6433END MODULE cv30_routines_mod
     6434
     6435

  • LMDZ6/trunk/libf/phylmdiso/cv3_routines.F90

    r5276 r5283  
    1111  USE ioipsl_getin_p_mod, ONLY : getin_p
    1212  use mod_phys_lmdz_para
    13 
     13  USE conema3_mod_h
    1414  IMPLICIT NONE
    1515
    … …  
    3838
    3939  include "cv3param.h"
    40   include "conema3.h"
    4140
    4241  INTEGER, INTENT(IN)              :: nd
    … …  
    14931492  USE cvflag_mod_h, ONLY: icvflag_Tpa, cvflag_grav, cvflag_ice, ok_optim_yield, ok_entrain, ok_homo_tend, &
    14941493          ok_convstop, ok_intermittent, cvflag_prec_eject, qsat_depends_on_qt, adiab_ascent_mass_flux_depends_on_ejectliq, keepbug_ice_frac
     1494  USE conema3_mod_h
    14951495  IMPLICIT NONE
    14961496
    … …  
    15141514
    15151515  include "cv3param.h"
    1516   include "conema3.h"
    15171516  include "YOMCST2.h"
    15181517
    … …  
    47344733#endif
    47354734#endif
    4736   USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
     4735USE conema3_mod_h
     4736    USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    47374737          , clmci, eps, epsi, epsim1, ginv, hrd, grav
    47384738  USE cvflag_mod_h, ONLY: icvflag_Tpa, cvflag_grav, cvflag_ice, ok_optim_yield, ok_entrain, ok_homo_tend, &
    … …  
    47414741
    47424742  include "cv3param.h"
    4743   include "conema3.h"
    47444743
    47454744!inputs:
    … …  
    76257624                 , pbase, p, ph, tv, buoy, sig, w0,iflag &
    76267625                 , epmax_diag)
    7627         USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
     7626USE conema3_mod_h
     7627          USE cvthermo_mod_h, ONLY: cpd, cpv, cl, ci, rrv, rrd, lv0, lf0, g, rowl, t0, clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl  &
    76287628          , clmci, eps, epsi, epsim1, ginv, hrd, grav
    76297629  USE cvflag_mod_h, ONLY: icvflag_Tpa, cvflag_grav, cvflag_ice, ok_optim_yield, ok_entrain, ok_homo_tend, &
    … …  
    76377637
    76387638  include "cv3param.h"
    7639   include "conema3.h"
    76407639
    76417640! inputs:

  • LMDZ6/trunk/libf/phylmdiso/cv_driver.F90

    r5276 r5283  
    4242#endif
    4343#endif
     44  USE cv30_routines_mod, ONLY: cv30_param, cv30_prelim, cv30_feed, cv30_undilute1, cv30_trigger, cv30_compress, cv30_undilute2, &
     45          cv30_closure, cv30_epmax_fn_cape, cv30_mixing, cv30_unsat, cv30_yield, cv30_tracer, cv30_uncompress
    4446  IMPLICIT NONE
    4547

  • LMDZ6/trunk/libf/phylmdiso/physiq_mod.F90

    r5282 r5283  
    444444          , RALPD, RBETD, RGAMD
    445445       USE clesphys_mod_h
     446       USE conema3_mod_h
    446447
    447448    IMPLICIT NONE
    … …  
    12951296    include "FCTTRE.h"
    12961297    !IM 100106 BEG : pouvoir sortir les ctes de la physique
    1297     include "conema3.h"
    12981298    include "nuage.h"
    12991299    include "compbl.h"
Note: See TracChangeset for help on using the changeset viewer.