Changeset 5142


Ignore:
Timestamp:
Jul 29, 2024, 3:07:34 PM (5 months ago)
Author:
abarral
Message:

Put cvparam.h, fcg_gcssold.h, planete.h, tsoilnudge.h, YOECUMF.h into modules

Location:
LMDZ6/branches/Amaury_dev/libf
Files:
2 deleted
40 edited
12 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/bcscav_spl.f90

    r5105 r5142  
    22
    33  USE dimphy
     4  USE lmdz_YOECUMF
     5
    46  IMPLICIT NONE
    57  !=====================================================================
    … …  
    1214  INCLUDE "chem.h"
    1315  INCLUDE "YOMCST.h"
    14   INCLUDE "YOECUMF.h"
    1516  !
    1617  REAL :: pdtime, alpha_r, alpha_s, R_r, R_s

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/gastoparticle.f90

    r5105 r5142  
    66  USE dimphy
    77  USE infotrac
     8  USE lmdz_YOECUMF
    89  ! USE indice_sol_mod
    910
    … …  
    1415  INCLUDE "chem_spla.h"
    1516  INCLUDE "YOMCST.h"
    16   INCLUDE "YOECUMF.h"
    1717  !
    1818  REAL :: pdtphys

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/inscav_spl.f90

    r5113 r5142  
    33        his_dh)
    44  USE dimphy
     5  USE lmdz_YOECUMF
     6
    57  IMPLICIT NONE
    68  !=====================================================================
    … …  
    1315  INCLUDE "chem.h"
    1416  INCLUDE "YOMCST.h"
    15   INCLUDE "YOECUMF.h"
    1617  !
    1718  INTEGER :: it

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/lsc_scav_orig.F90

    r5134 r5142  
    1212  USE iophy
    1313  USE lmdz_yomcst
     14  USE lmdz_YOECUMF
    1415
    1516  IMPLICIT NONE
    … …  
    2324  INCLUDE "dimensions.h"
    2425  INCLUDE "chem.h"
    25   INCLUDE "YOECUMF.h"
    2626
    2727  REAL,INTENT(IN)                        :: pdtime ! time step (s)

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/lsc_scav_spl.F90

    r5134 r5142  
    1414  USE iophy
    1515  USE lmdz_yomcst
     16  USE lmdz_YOECUMF
     17
    1618  IMPLICIT NONE
    1719!=====================================================================
    … …  
    2527  INCLUDE "dimensions.h"
    2628  INCLUDE "chem.h"
    27   INCLUDE "YOECUMF.h"
    2829
    2930  REAL,INTENT(IN)                        :: pdtime ! time step (s)

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/seasalt.f90

    r5105 r5142  
    55
    66  USE dimphy
     7  USE lmdz_YOECUMF
     8
    79  IMPLICIT NONE
    810  !
    … …  
    1113  INCLUDE "chem_spla.h"
    1214  INCLUDE "YOMCST.h"
    13   INCLUDE "YOECUMF.h"
    1415  !
    1516  INTEGER :: i, bin                 !local variables

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/sediment_mod.f90

    r5113 r5142  
    1010  USE dimphy
    1111  USE infotrac
     12  USE lmdz_YOECUMF
     13
    1214  IMPLICIT NONE
    1315  !
    … …  
    1517  INCLUDE "chem.h"
    1618  INCLUDE "YOMCST.h"
    17   INCLUDE "YOECUMF.h"
    1819  !
    1920  REAL :: RHcl(klon, klev)     ! humidite relative ciel clair

  • LMDZ6/branches/Amaury_dev/libf/phylmd/alpale_th.F90

    r5134 r5142  
    2222  USE lmdz_abort_physic, ONLY: abort_physic
    2323  USE lmdz_alpale
     24  USE lmdz_cv, ONLY: cv_feed
    2425
    2526  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/phylmd/conflx.F90

    r5112 r5142  
    1 
    21! $Header$
    32
    43SUBROUTINE conflx(dtime, pres_h, pres_f, t, q, con_t, con_q, pqhfl, w, d_t, &
    5     d_q, rain, snow, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, kcbot, kctop, &
    6     kdtop, pmflxr, pmflxs)
     4        d_q, rain, snow, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, kcbot, kctop, &
     5        kdtop, pmflxr, pmflxs)
    76
    87  USE dimphy
    … …  
    2019  ! Entree:
    2120  REAL dtime ! pas d'integration (s)
    22   REAL pres_h(klon, klev+1) ! pression half-level (Pa)
     21  REAL pres_h(klon, klev + 1) ! pression half-level (Pa)
    2322  REAL pres_f(klon, klev) ! pression full-level (Pa)
    2423  REAL t(klon, klev) ! temperature (K)
    … …  
    3938  REAL rain(klon) ! pluie (mm/s)
    4039  REAL snow(klon) ! neige (mm/s)
    41   REAL pmflxr(klon, klev+1)
    42   REAL pmflxs(klon, klev+1)
     40  REAL pmflxr(klon, klev + 1)
     41  REAL pmflxs(klon, klev + 1)
    4342  INTEGER kcbot(klon) ! niveau du bas de la convection
    4443  INTEGER kctop(klon) ! niveau du haut de la convection
    … …  
    5352  REAL d_t_bis(klon, klev)
    5453  REAL d_q_bis(klon, klev)
    55   REAL paprs(klon, klev+1)
     54  REAL paprs(klon, klev + 1)
    5655  REAL paprsf(klon, klev)
    5756  REAL zgeom(klon, klev)
    … …  
    6564  REAL zde_u(klon, klev)
    6665  REAL zde_d(klon, klev)
    67   REAL zmflxr(klon, klev+1)
    68   REAL zmflxs(klon, klev+1)
     66  REAL zmflxr(klon, klev + 1)
     67  REAL zmflxs(klon, klev + 1)
    6968  ! AA
    70 
    7169
    7270  INTEGER i, k
    … …  
    117115  DO k = 1, klev
    118116    DO i = 1, klon
    119       pt(i, k) = t(i, klev-k+1)
    120       pq(i, k) = q(i, klev-k+1)
    121       paprsf(i, k) = pres_f(i, klev-k+1)
    122       paprs(i, k) = pres_h(i, klev+1-k+1)
    123       pvervel(i, k) = w(i, klev+1-k)
    124       zcvgt(i, k) = con_t(i, klev-k+1)
    125       zcvgq(i, k) = con_q(i, klev-k+1)
    126 
    127       zdelta = max(0., sign(1.,rtt-pt(i,k)))
    128       zqsat = r2es*foeew(pt(i,k), zdelta)/paprsf(i, k)
     117      pt(i, k) = t(i, klev - k + 1)
     118      pq(i, k) = q(i, klev - k + 1)
     119      paprsf(i, k) = pres_f(i, klev - k + 1)
     120      paprs(i, k) = pres_h(i, klev + 1 - k + 1)
     121      pvervel(i, k) = w(i, klev + 1 - k)
     122      zcvgt(i, k) = con_t(i, klev - k + 1)
     123      zcvgq(i, k) = con_q(i, klev - k + 1)
     124
     125      zdelta = max(0., sign(1., rtt - pt(i, k)))
     126      zqsat = r2es * foeew(pt(i, k), zdelta) / paprsf(i, k)
    129127      zqsat = min(0.5, zqsat)
    130       zqsat = zqsat/(1.-retv*zqsat)
     128      zqsat = zqsat / (1. - retv * zqsat)
    131129      pqs(i, k) = zqsat
    132130    END DO
    133131  END DO
    134132  DO i = 1, klon
    135     paprs(i, klev+1) = pres_h(i, 1)
    136     zgeom(i, klev) = rd*pt(i, klev)/(0.5*(paprs(i,klev+1)+paprsf(i, &
    137       klev)))*(paprs(i,klev+1)-paprsf(i,klev))
     133    paprs(i, klev + 1) = pres_h(i, 1)
     134    zgeom(i, klev) = rd * pt(i, klev) / (0.5 * (paprs(i, klev + 1) + paprsf(i, &
     135            klev))) * (paprs(i, klev + 1) - paprsf(i, klev))
    138136  END DO
    139137  DO k = klev - 1, 1, -1
    140138    DO i = 1, klon
    141       zgeom(i, k) = zgeom(i, k+1) + rd*0.5*(pt(i,k+1)+pt(i,k))/paprs(i, k+1)* &
    142         (paprsf(i,k+1)-paprsf(i,k))
     139      zgeom(i, k) = zgeom(i, k + 1) + rd * 0.5 * (pt(i, k + 1) + pt(i, k)) / paprs(i, k + 1) * &
     140              (paprsf(i, k + 1) - paprsf(i, k))
    143141    END DO
    144142  END DO
    … …  
    147145
    148146  CALL flxmain(dtime, pt, pq, pqs, pqhfl, paprsf, paprs, zgeom, land, zcvgt, &
    149     zcvgq, pvervel, rain, snow, kcbot, kctop, kdtop, zmfu, zmfd, zen_u, &
    150     zde_u, zen_d, zde_d, d_t_bis, d_q_bis, zmflxr, zmflxs)
     147          zcvgq, pvervel, rain, snow, kcbot, kctop, kdtop, zmfu, zmfd, zen_u, &
     148          zde_u, zen_d, zde_d, d_t_bis, d_q_bis, zmflxr, zmflxs)
    151149
    152150  ! AA--------------------------------------------------------
    … …  
    158156  DO k = 1, klev
    159157    DO i = 1, klon
    160       d_q(i, klev+1-k) = dtime*d_q_bis(i, k)
    161       d_t(i, klev+1-k) = dtime*d_t_bis(i, k)
     158      d_q(i, klev + 1 - k) = dtime * d_q_bis(i, k)
     159      d_t(i, klev + 1 - k) = dtime * d_t_bis(i, k)
    162160    END DO
    163161  END DO
    … …  
    172170  DO k = 2, klev
    173171    DO i = 1, klon
    174       pmfu(i, klev+2-k) = zmfu(i, k)
    175       pmfd(i, klev+2-k) = zmfd(i, k)
     172      pmfu(i, klev + 2 - k) = zmfu(i, k)
     173      pmfd(i, klev + 2 - k) = zmfd(i, k)
    176174    END DO
    177175  END DO
    … …  
    179177  DO k = 1, klev
    180178    DO i = 1, klon
    181       pen_u(i, klev+1-k) = zen_u(i, k)
    182       pde_u(i, klev+1-k) = zde_u(i, k)
     179      pen_u(i, klev + 1 - k) = zen_u(i, k)
     180      pde_u(i, klev + 1 - k) = zde_u(i, k)
    183181    END DO
    184182  END DO
    … …  
    186184  DO k = 1, klev - 1
    187185    DO i = 1, klon
    188       pen_d(i, klev+1-k) = -zen_d(i, k+1)
    189       pde_d(i, klev+1-k) = -zde_d(i, k+1)
     186      pen_d(i, klev + 1 - k) = -zen_d(i, k + 1)
     187      pde_d(i, klev + 1 - k) = -zde_d(i, k + 1)
    190188    END DO
    191189  END DO
    … …  
    193191  DO k = 1, klev + 1
    194192    DO i = 1, klon
    195       pmflxr(i, klev+2-k) = zmflxr(i, k)
    196       pmflxs(i, klev+2-k) = zmflxs(i, k)
    197     END DO
    198   END DO
    199 
     193      pmflxr(i, klev + 2 - k) = zmflxr(i, k)
     194      pmflxs(i, klev + 2 - k) = zmflxs(i, k)
     195    END DO
     196  END DO
    200197
    201198END SUBROUTINE conflx
    202199! --------------------------------------------------------------------
    203200SUBROUTINE flxmain(pdtime, pten, pqen, pqsen, pqhfl, pap, paph, pgeo, ldland, &
    204     ptte, pqte, pvervel, prsfc, pssfc, kcbot, kctop, kdtop, & ! *
    205                                                               ! ldcum, ktype,
    206     pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, dt_con, dq_con, pmflxr, pmflxs)
     201        ptte, pqte, pvervel, prsfc, pssfc, kcbot, kctop, kdtop, & ! *
     202        ! ldcum, ktype,
     203        pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, dt_con, dq_con, pmflxr, pmflxs)
    207204  USE dimphy
     205  USE lmdz_YOECUMF
     206
    208207  IMPLICIT NONE
    209208  ! ------------------------------------------------------------------
    210209  include "YOMCST.h"
    211210  include "YOETHF.h"
    212   include "YOECUMF.h"
    213211  ! ----------------------------------------------------------------
    214212  REAL pten(klon, klev), pqen(klon, klev), pqsen(klon, klev)
    … …  
    216214  REAL pqte(klon, klev)
    217215  REAL pvervel(klon, klev)
    218   REAL pgeo(klon, klev), pap(klon, klev), paph(klon, klev+1)
     216  REAL pgeo(klon, klev), pap(klon, klev), paph(klon, klev + 1)
    219217  REAL pqhfl(klon)
    220218
    … …  
    234232  REAL zdqpbl(klon), zdqcv(klon), zdhpbl(klon)
    235233  REAL zrfl(klon)
    236   REAL pmflxr(klon, klev+1)
    237   REAL pmflxs(klon, klev+1)
     234  REAL pmflxr(klon, klev + 1)
     235  REAL pmflxs(klon, klev + 1)
    238236  INTEGER ilab(klon, klev), ictop0(klon)
    239237  LOGICAL llo1
    … …  
    275273  ! ----------------------------------------------------------------------
    276274  CALL flxini(pten, pqen, pqsen, pgeo, paph, zgeoh, ztenh, zqenh, zqsenh, &
    277     ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp, pmfu, zmfus, zmfuq, &
    278     zdmfup, zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d)
     275          ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp, pmfu, zmfus, zmfuq, &
     276          zdmfup, zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d)
    279277  ! ---------------------------------------------------------------------
    280278  ! determiner les valeurs au niveau de base de la tour convective
    … …  
    290288  k = 1
    291289  DO i = 1, klon
    292     zdqcv(i) = pqte(i, k)*(paph(i,k+1)-paph(i,k))
     290    zdqcv(i) = pqte(i, k) * (paph(i, k + 1) - paph(i, k))
    293291    zdhpbl(i) = 0.0
    294292    zdqpbl(i) = 0.0
    … …  
    297295  DO k = 2, klev
    298296    DO i = 1, klon
    299       zdqcv(i) = zdqcv(i) + pqte(i, k)*(paph(i,k+1)-paph(i,k))
     297      zdqcv(i) = zdqcv(i) + pqte(i, k) * (paph(i, k + 1) - paph(i, k))
    300298      IF (k>=kcbot(i)) THEN
    301         zdqpbl(i) = zdqpbl(i) + pqte(i, k)*(paph(i,k+1)-paph(i,k))
    302         zdhpbl(i) = zdhpbl(i) + (rcpd*ptte(i,k)+rlvtt*pqte(i,k))*(paph(i,k+1) &
    303           -paph(i,k))
     299        zdqpbl(i) = zdqpbl(i) + pqte(i, k) * (paph(i, k + 1) - paph(i, k))
     300        zdhpbl(i) = zdhpbl(i) + (rcpd * ptte(i, k) + rlvtt * pqte(i, k)) * (paph(i, k + 1) &
     301                - paph(i, k))
    304302      END IF
    305303    END DO
    … …  
    308306  DO i = 1, klon
    309307    ktype(i) = 2
    310     IF (zdqcv(i)>max(0.,-1.5*pqhfl(i)*rg)) ktype(i) = 1
     308    IF (zdqcv(i)>max(0., -1.5 * pqhfl(i) * rg)) ktype(i) = 1
    311309    ! cc         if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1
    312310  END DO
    … …  
    319317    ikb = kcbot(i)
    320318    zqumqe = pqu(i, ikb) + plu(i, ikb) - zqenh(i, ikb)
    321     zdqmin = max(0.01*zqenh(i,ikb), 1.E-10)
     319    zdqmin = max(0.01 * zqenh(i, ikb), 1.E-10)
    322320    IF (zdqpbl(i)>0. .AND. zqumqe>zdqmin .AND. ldcum(i)) THEN
    323       zmfub(i) = zdqpbl(i)/(rg*max(zqumqe,zdqmin))
     321      zmfub(i) = zdqpbl(i) / (rg * max(zqumqe, zdqmin))
    324322    ELSE
    325323      zmfub(i) = 0.01
    … …  
    327325    END IF
    328326    IF (ktype(i)==2) THEN
    329       zdh = rcpd*(ptu(i,ikb)-ztenh(i,ikb)) + rlvtt*zqumqe
    330       zdh = rg*max(zdh, 1.0E5*zdqmin)
    331       IF (zdhpbl(i)>0. .AND. ldcum(i)) zmfub(i) = zdhpbl(i)/zdh
     327      zdh = rcpd * (ptu(i, ikb) - ztenh(i, ikb)) + rlvtt * zqumqe
     328      zdh = rg * max(zdh, 1.0E5 * zdqmin)
     329      IF (zdhpbl(i)>0. .AND. ldcum(i)) zmfub(i) = zdhpbl(i) / zdh
    332330    END IF
    333     zmfmax = (paph(i,ikb)-paph(i,ikb-1))/(rg*pdtime)
     331    zmfmax = (paph(i, ikb) - paph(i, ikb - 1)) / (rg * pdtime)
    334332    zmfub(i) = min(zmfub(i), zmfmax)
    335333    zentr(i) = entrscv
    … …  
    345343  DO i = 1, klon
    346344    ikb = kcbot(i)
    347     zhcbase(i) = rcpd*ptu(i, ikb) + zgeoh(i, ikb) + rlvtt*pqu(i, ikb)
     345    zhcbase(i) = rcpd * ptu(i, ikb) + zgeoh(i, ikb) + rlvtt * pqu(i, ikb)
    348346    ictop0(i) = kcbot(i) - 1
    349347  END DO
    350348
    351   zalvdcp = rlvtt/rcpd
     349  zalvdcp = rlvtt / rcpd
    352350  DO k = klev - 1, 3, -1
    353351    DO i = 1, klon
    354       zhsat = rcpd*ztenh(i, k) + zgeoh(i, k) + rlvtt*zqsenh(i, k)
    355       zgam = r5les*zalvdcp*zqsenh(i, k)/((1.-retv*zqsenh(i,k))*(ztenh(i, &
    356         k)-r4les)**2)
    357       zzz = rcpd*ztenh(i, k)*0.608
    358       zhhat = zhsat - (zzz+zgam*zzz)/(1.+zgam*zzz/rlvtt)*max(zqsenh(i,k)- &
    359         zqenh(i,k), 0.)
     352      zhsat = rcpd * ztenh(i, k) + zgeoh(i, k) + rlvtt * zqsenh(i, k)
     353      zgam = r5les * zalvdcp * zqsenh(i, k) / ((1. - retv * zqsenh(i, k)) * (ztenh(i, &
     354              k) - r4les)**2)
     355      zzz = rcpd * ztenh(i, k) * 0.608
     356      zhhat = zhsat - (zzz + zgam * zzz) / (1. + zgam * zzz / rlvtt) * max(zqsenh(i, k) - &
     357              zqenh(i, k), 0.)
    360358      IF (k<ictop0(i) .AND. zhcbase(i)>zhhat) ictop0(i) = k
    361359    END DO
    … …  
    365363
    366364  CALL flxasc(pdtime, ztenh, zqenh, pten, pqen, pqsen, pgeo, zgeoh, pap, &
    367     paph, pqte, pvervel, ldland, ldcum, ktype, ilab, ptu, pqu, plu, pmfu, &
    368     zmfub, zentr, zmfus, zmfuq, zmful, plude, zdmfup, kcbot, kctop, ictop0, &
    369     kcum, pen_u, pde_u)
     365          paph, pqte, pvervel, ldland, ldcum, ktype, ilab, ptu, pqu, plu, pmfu, &
     366          zmfub, zentr, zmfus, zmfuq, zmful, plude, zdmfup, kcbot, kctop, ictop0, &
     367          kcum, pen_u, pde_u)
    370368  IF (kcum==0) GO TO 1000
    371369
    … …  
    395393    ! determiner le LFS (level of free sinking: niveau de plonge libre)
    396394    CALL flxdlfs(ztenh, zqenh, zgeoh, paph, ptu, pqu, ldcum, kcbot, kctop, &
    397       zmfub, zrfl, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp, kdtop, lddraf)
     395            zmfub, zrfl, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp, kdtop, lddraf)
    398396
    399397    ! calculer le panache descendant
    400398    CALL flxddraf(ztenh, zqenh, zgeoh, paph, zrfl, ptd, pqd, pmfd, zmfds, &
    401       zmfdq, zdmfdp, lddraf, pen_d, pde_d)
     399            zmfdq, zdmfdp, lddraf, pen_d, pde_d)
    402400
    403401    ! calculer de nouveau le flux de masse entrant a travers la base
    … …  
    410408        zeps = 0.
    411409        IF (llo1) zeps = cmfdeps
    412         zqumqe = pqu(i, ikb) + plu(i, ikb) - zeps*pqd(i, ikb) - &
    413           (1.-zeps)*zqenh(i, ikb)
    414         zdqmin = max(0.01*zqenh(i,ikb), 1.E-10)
    415         zmfmax = (paph(i,ikb)-paph(i,ikb-1))/(rg*pdtime)
     410        zqumqe = pqu(i, ikb) + plu(i, ikb) - zeps * pqd(i, ikb) - &
     411                (1. - zeps) * zqenh(i, ikb)
     412        zdqmin = max(0.01 * zqenh(i, ikb), 1.E-10)
     413        zmfmax = (paph(i, ikb) - paph(i, ikb - 1)) / (rg * pdtime)
    416414        IF (zdqpbl(i)>0. .AND. zqumqe>zdqmin .AND. ldcum(i) .AND. &
    417             zmfub(i)<zmfmax) THEN
    418           zmfub1(i) = zdqpbl(i)/(rg*max(zqumqe,zdqmin))
     415                zmfub(i)<zmfmax) THEN
     416          zmfub1(i) = zdqpbl(i) / (rg * max(zqumqe, zdqmin))
    419417        ELSE
    420418          zmfub1(i) = zmfub(i)
    421419        END IF
    422420        IF (ktype(i)==2) THEN
    423           zdh = rcpd*(ptu(i,ikb)-zeps*ptd(i,ikb)-(1.-zeps)*ztenh(i,ikb)) + &
    424             rlvtt*zqumqe
    425           zdh = rg*max(zdh, 1.0E5*zdqmin)
    426           IF (zdhpbl(i)>0. .AND. ldcum(i)) zmfub1(i) = zdhpbl(i)/zdh
     421          zdh = rcpd * (ptu(i, ikb) - zeps * ptd(i, ikb) - (1. - zeps) * ztenh(i, ikb)) + &
     422                  rlvtt * zqumqe
     423          zdh = rg * max(zdh, 1.0E5 * zdqmin)
     424          IF (zdhpbl(i)>0. .AND. ldcum(i)) zmfub1(i) = zdhpbl(i) / zdh
    427425        END IF
    428         IF (.NOT. ((ktype(i)==1 .OR. ktype(i)==2) .AND. abs(zmfub1(i)-zmfub(i &
    429           ))<0.2*zmfub(i))) zmfub1(i) = zmfub(i)
     426        IF (.NOT. ((ktype(i)==1 .OR. ktype(i)==2) .AND. abs(zmfub1(i) - zmfub(i &
     427                ))<0.2 * zmfub(i))) zmfub1(i) = zmfub(i)
    430428      END IF
    431429    END DO
    … …  
    433431      DO i = 1, klon
    434432        IF (lddraf(i)) THEN
    435           zfac = zmfub1(i)/max(zmfub(i), 1.E-10)
    436           pmfd(i, k) = pmfd(i, k)*zfac
    437           zmfds(i, k) = zmfds(i, k)*zfac
    438           zmfdq(i, k) = zmfdq(i, k)*zfac
    439           zdmfdp(i, k) = zdmfdp(i, k)*zfac
    440           pen_d(i, k) = pen_d(i, k)*zfac
    441           pde_d(i, k) = pde_d(i, k)*zfac
     433          zfac = zmfub1(i) / max(zmfub(i), 1.E-10)
     434          pmfd(i, k) = pmfd(i, k) * zfac
     435          zmfds(i, k) = zmfds(i, k) * zfac
     436          zmfdq(i, k) = zmfdq(i, k) * zfac
     437          zdmfdp(i, k) = zdmfdp(i, k) * zfac
     438          pen_d(i, k) = pen_d(i, k) * zfac
     439          pde_d(i, k) = pde_d(i, k) * zfac
    442440        END IF
    443441      END DO
    … …  
    453451  ! -----------------------------------------------------------------------
    454452  CALL flxasc(pdtime, ztenh, zqenh, pten, pqen, pqsen, pgeo, zgeoh, pap, &
    455     paph, pqte, pvervel, ldland, ldcum, ktype, ilab, ptu, pqu, plu, pmfu, &
    456     zmfub, zentr, zmfus, zmfuq, zmful, plude, zdmfup, kcbot, kctop, ictop0, &
    457     kcum, pen_u, pde_u)
     453          paph, pqte, pvervel, ldland, ldcum, ktype, ilab, ptu, pqu, plu, pmfu, &
     454          zmfub, zentr, zmfus, zmfuq, zmful, plude, zdmfup, kcbot, kctop, ictop0, &
     455          kcum, pen_u, pde_u)
    458456
    459457  ! -----------------------------------------------------------------------
    … …  
    462460  ! -----------------------------------------------------------------------
    463461  CALL flxflux(pdtime, pqen, pqsen, ztenh, zqenh, pap, paph, ldland, zgeoh, &
    464     kcbot, kctop, lddraf, kdtop, ktype, ldcum, pmfu, pmfd, zmfus, zmfds, &
    465     zmfuq, zmfdq, zmful, plude, zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, &
    466     itopm2, pmflxr, pmflxs)
     462          kcbot, kctop, lddraf, kdtop, ktype, ldcum, pmfu, pmfd, zmfus, zmfds, &
     463          zmfuq, zmfdq, zmful, plude, zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, &
     464          itopm2, pmflxr, pmflxs)
    467465
    468466  ! ----------------------------------------------------------------------
    … …  
    470468  ! ----------------------------------------------------------------------
    471469  CALL flxdtdq(pdtime, itopm2, paph, ldcum, pten, zmfus, zmfds, zmfuq, zmfdq, &
    472     zmful, zdmfup, zdmfdp, zdpmel, dt_con, dq_con)
    473 
    474 1000 CONTINUE
     470          zmful, zdmfup, zdmfdp, zdpmel, dt_con, dq_con)
     471
     472  1000 CONTINUE
    475473
    476474END SUBROUTINE flxmain
    477475SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh, pqenh, pqsenh, &
    478     ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, pmfu, pmfus, pmfuq, &
    479     pdmfup, pdpmel, plu, plude, klab, pen_u, pde_u, pen_d, pde_d)
     476        ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, pmfu, pmfus, pmfuq, &
     477        pdmfup, pdpmel, plu, plude, klab, pen_u, pde_u, pen_d, pde_d)
    480478  USE dimphy
    481479  IMPLICIT NONE
    … …  
    493491  REAL pgeo(klon, klev) ! geopotentiel (g * metre)
    494492  REAL pgeoh(klon, klev) ! geopotentiel aux demi-niveaux
    495   REAL paph(klon, klev+1) ! pression aux demi-niveaux
     493  REAL paph(klon, klev + 1) ! pression aux demi-niveaux
    496494  REAL ptenh(klon, klev) ! temperature aux demi-niveaux
    497495  REAL pqenh(klon, klev) ! humidite aux demi-niveaux
    … …  
    532530
    533531    DO i = 1, klon
    534       pgeoh(i, k) = pgeo(i, k) + (pgeo(i,k-1)-pgeo(i,k))*0.5
    535       ptenh(i, k) = (max(rcpd*pten(i,k-1)+pgeo(i,k-1),rcpd*pten(i,k)+pgeo(i, &
    536         k))-pgeoh(i,k))/rcpd
    537       pqsenh(i, k) = pqsen(i, k-1)
     532      pgeoh(i, k) = pgeo(i, k) + (pgeo(i, k - 1) - pgeo(i, k)) * 0.5
     533      ptenh(i, k) = (max(rcpd * pten(i, k - 1) + pgeo(i, k - 1), rcpd * pten(i, k) + pgeo(i, &
     534              k)) - pgeoh(i, k)) / rcpd
     535      pqsenh(i, k) = pqsen(i, k - 1)
    538536      llflag(i) = .TRUE.
    539537    END DO
    540538
    541539    iCALL = 0
    542     CALL flxadjtq(paph(1,k), ptenh(1,k), pqsenh(1,k), llflag, icall)
    543 
    544     DO i = 1, klon
    545       pqenh(i, k) = min(pqen(i,k-1), pqsen(i,k-1)) + &
    546         (pqsenh(i,k)-pqsen(i,k-1))
    547       pqenh(i, k) = max(pqenh(i,k), 0.)
    548     END DO
    549 
    550   END DO
    551 
    552   DO i = 1, klon
    553     ptenh(i, klev) = (rcpd*pten(i,klev)+pgeo(i,klev)-pgeoh(i,klev))/rcpd
     540    CALL flxadjtq(paph(1, k), ptenh(1, k), pqsenh(1, k), llflag, icall)
     541
     542    DO i = 1, klon
     543      pqenh(i, k) = min(pqen(i, k - 1), pqsen(i, k - 1)) + &
     544              (pqsenh(i, k) - pqsen(i, k - 1))
     545      pqenh(i, k) = max(pqenh(i, k), 0.)
     546    END DO
     547
     548  END DO
     549
     550  DO i = 1, klon
     551    ptenh(i, klev) = (rcpd * pten(i, klev) + pgeo(i, klev) - pgeoh(i, klev)) / rcpd
    554552    pqenh(i, klev) = pqen(i, klev)
    555553    ptenh(i, 1) = pten(i, 1)
    … …  
    560558  DO k = klev - 1, 2, -1
    561559    DO i = 1, klon
    562       zzs = max(rcpd*ptenh(i,k)+pgeoh(i,k), rcpd*ptenh(i,k+1)+pgeoh(i,k+1))
    563       ptenh(i, k) = (zzs-pgeoh(i,k))/rcpd
     560      zzs = max(rcpd * ptenh(i, k) + pgeoh(i, k), rcpd * ptenh(i, k + 1) + pgeoh(i, k + 1))
     561      ptenh(i, k) = (zzs - pgeoh(i, k)) / rcpd
    564562    END DO
    565563  END DO
    … …  
    596594  END DO
    597595
    598 
    599596END SUBROUTINE flxini
    600597SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph, ptu, pqu, plu, ldcum, kcbot, &
    601     klab)
     598        klab)
    602599  USE dimphy
    603600  IMPLICIT NONE
    … …  
    617614  ! ----------------------------------------------------------------
    618615  REAL ptenh(klon, klev), pqenh(klon, klev)
    619   REAL pgeoh(klon, klev), paph(klon, klev+1)
     616  REAL pgeoh(klon, klev), paph(klon, klev + 1)
    620617
    621618  REAL ptu(klon, klev), pqu(klon, klev), plu(klon, klev)
    … …  
    643640    is = 0
    644641    DO i = 1, klon
    645       IF (klab(i,k+1)==1) is = is + 1
     642      IF (klab(i, k + 1)==1) is = is + 1
    646643      llflag(i) = .FALSE.
    647       IF (klab(i,k+1)==1) llflag(i) = .TRUE.
     644      IF (klab(i, k + 1)==1) llflag(i) = .TRUE.
    648645    END DO
    649646    IF (is==0) GO TO 290
    … …  
    651648    DO i = 1, klon
    652649      IF (llflag(i)) THEN
    653         pqu(i, k) = pqu(i, k+1)
    654         ptu(i, k) = ptu(i, k+1) + (pgeoh(i,k+1)-pgeoh(i,k))/rcpd
    655         zbuo = ptu(i, k)*(1.+retv*pqu(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
    656           ) + 0.5
     650        pqu(i, k) = pqu(i, k + 1)
     651        ptu(i, k) = ptu(i, k + 1) + (pgeoh(i, k + 1) - pgeoh(i, k)) / rcpd
     652        zbuo = ptu(i, k) * (1. + retv * pqu(i, k)) - ptenh(i, k) * (1. + retv * pqenh(i, k) &
     653                ) + 0.5
    657654        IF (zbuo>0.) klab(i, k) = 1
    658655        zqold(i) = pqu(i, k)
    … …  
    661658
    662659    iCALL = 1
    663     CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
    664 
    665     DO i = 1, klon
    666       IF (llflag(i) .AND. pqu(i,k)/=zqold(i)) THEN
     660    CALL flxadjtq(paph(1, k), ptu(1, k), pqu(1, k), llflag, icall)
     661
     662    DO i = 1, klon
     663      IF (llflag(i) .AND. pqu(i, k)/=zqold(i)) THEN
    667664        klab(i, k) = 2
    668665        plu(i, k) = plu(i, k) + zqold(i) - pqu(i, k)
    669         zbuo = ptu(i, k)*(1.+retv*pqu(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
    670           ) + 0.5
     666        zbuo = ptu(i, k) * (1. + retv * pqu(i, k)) - ptenh(i, k) * (1. + retv * pqenh(i, k) &
     667                ) + 0.5
    671668        IF (zbuo>0.) kcbot(i) = k
    672669        IF (zbuo>0.) ldcum(i) = .TRUE.
    … …  
    674671    END DO
    675672
    676 290 END DO
    677 
     673  290 END DO
    678674
    679675END SUBROUTINE flxbase
    680676SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen, pgeo, pgeoh, pap, &
    681     paph, pqte, pvervel, ldland, ldcum, ktype, klab, ptu, pqu, plu, pmfu, &
    682     pmfub, pentr, pmfus, pmfuq, pmful, plude, pdmfup, kcbot, kctop, kctop0, &
    683     kcum, pen_u, pde_u)
     677        paph, pqte, pvervel, ldland, ldcum, ktype, klab, ptu, pqu, plu, pmfu, &
     678        pmfub, pentr, pmfus, pmfuq, pmful, plude, pdmfup, kcbot, kctop, kctop0, &
     679        kcum, pen_u, pde_u)
    684680  USE dimphy
     681  USE lmdz_YOECUMF
     682
    685683  IMPLICIT NONE
    686684  ! ----------------------------------------------------------------------
    … …  
    690688  include "YOMCST.h"
    691689  include "YOETHF.h"
    692   include "YOECUMF.h"
    693690
    694691  REAL pdtime
    … …  
    696693  REAL pqen(klon, klev), pqenh(klon, klev), pqsen(klon, klev)
    697694  REAL pgeo(klon, klev), pgeoh(klon, klev)
    698   REAL pap(klon, klev), paph(klon, klev+1)
     695  REAL pap(klon, klev), paph(klon, klev + 1)
    699696  REAL pqte(klon, klev)
    700697  REAL pvervel(klon, klev) ! vitesse verticale en Pa/s
    … …  
    735732  DO k = klev, 3, -1
    736733    DO i = 1, klon
    737       IF (pvervel(i,k)<zwmax(i)) THEN
     734      IF (pvervel(i, k)<zwmax(i)) THEN
    738735        zwmax(i) = pvervel(i, k)
    739736        klwmin(i) = k
    … …  
    758755      pdmfup(i, k) = 0.
    759756      IF (.NOT. ldcum(i) .OR. ktype(i)==3) klab(i, k) = 0
    760       IF (.NOT. ldcum(i) .AND. paph(i,k)<4.E4) kctop0(i) = k
     757      IF (.NOT. ldcum(i) .AND. paph(i, k)<4.E4) kctop0(i) = k
    761758    END DO
    762759  END DO
    … …  
    766763      zdland(i) = 3.0E4
    767764      zdphi = pgeoh(i, kctop0(i)) - pgeoh(i, kcbot(i))
    768       IF (ptu(i,kctop0(i))>=ztglace) zdland(i) = zdphi
     765      IF (ptu(i, kctop0(i))>=ztglace) zdland(i) = zdphi
    769766      zdland(i) = max(3.0E4, zdland(i))
    770767      zdland(i) = min(5.0E4, zdland(i))
    … …  
    782779    END IF
    783780    pmfu(i, klev) = pmfub(i)
    784     pmfus(i, klev) = pmfub(i)*(rcpd*ptu(i,klev)+pgeoh(i,klev))
    785     pmfuq(i, klev) = pmfub(i)*pqu(i, klev)
     781    pmfus(i, klev) = pmfub(i) * (rcpd * ptu(i, klev) + pgeoh(i, klev))
     782    pmfuq(i, klev) = pmfub(i) * pqu(i, klev)
    786783  END DO
    787784
    … …  
    797794  DO k = klev - 1, 3, -1
    798795
    799     IF (lmfmid .AND. k<klev-1) THEN
     796    IF (lmfmid .AND. k<klev - 1) THEN
    800797      DO i = 1, klon
    801         IF (.NOT. ldcum(i) .AND. klab(i,k+1)==0 .AND. &
    802             pqen(i,k)>0.9*pqsen(i,k) .AND. pap(i,k)/paph(i,klev+1)>0.4) THEN
    803           ptu(i, k+1) = pten(i, k) + (pgeo(i,k)-pgeoh(i,k+1))/rcpd
    804           pqu(i, k+1) = pqen(i, k)
    805           plu(i, k+1) = 0.0
    806           zzzmb = max(cmfcmin, -pvervel(i,k)/rg)
    807           zmfmax = (paph(i,k)-paph(i,k-1))/(rg*pdtime)
     798        IF (.NOT. ldcum(i) .AND. klab(i, k + 1)==0 .AND. &
     799                pqen(i, k)>0.9 * pqsen(i, k) .AND. pap(i, k) / paph(i, klev + 1)>0.4) THEN
     800          ptu(i, k + 1) = pten(i, k) + (pgeo(i, k) - pgeoh(i, k + 1)) / rcpd
     801          pqu(i, k + 1) = pqen(i, k)
     802          plu(i, k + 1) = 0.0
     803          zzzmb = max(cmfcmin, -pvervel(i, k) / rg)
     804          zmfmax = (paph(i, k) - paph(i, k - 1)) / (rg * pdtime)
    808805          pmfub(i) = min(zzzmb, zmfmax)
    809           pmfu(i, k+1) = pmfub(i)
    810           pmfus(i, k+1) = pmfub(i)*(rcpd*ptu(i,k+1)+pgeoh(i,k+1))
    811           pmfuq(i, k+1) = pmfub(i)*pqu(i, k+1)
    812           pmful(i, k+1) = 0.0
    813           pdmfup(i, k+1) = 0.0
     806          pmfu(i, k + 1) = pmfub(i)
     807          pmfus(i, k + 1) = pmfub(i) * (rcpd * ptu(i, k + 1) + pgeoh(i, k + 1))
     808          pmfuq(i, k + 1) = pmfub(i) * pqu(i, k + 1)
     809          pmful(i, k + 1) = 0.0
     810          pdmfup(i, k + 1) = 0.0
    814811          kcbot(i) = k
    815           klab(i, k+1) = 1
     812          klab(i, k + 1) = 1
    816813          ktype(i) = 3
    817814          pentr(i) = entrmid
    … …  
    822819    is = 0
    823820    DO i = 1, klon
    824       is = is + klab(i, k+1)
    825       IF (klab(i,k+1)==0) klab(i, k) = 0
     821      is = is + klab(i, k + 1)
     822      IF (klab(i, k + 1)==0) klab(i, k) = 0
    826823      llflag(i) = .FALSE.
    827       IF (klab(i,k+1)>0) llflag(i) = .TRUE.
     824      IF (klab(i, k + 1)>0) llflag(i) = .TRUE.
    828825    END DO
    829826    IF (is==0) GO TO 480
    … …  
    834831      pen_u(i, k) = 0.0
    835832      pde_u(i, k) = 0.0
    836       zrho(i) = paph(i, k+1)/(rd*ptenh(i,k+1))
     833      zrho(i) = paph(i, k + 1) / (rd * ptenh(i, k + 1))
    837834      zpbot(i) = paph(i, kcbot(i))
    838835      zptop(i) = paph(i, kctop0(i))
    … …  
    841838    DO i = 1, klon
    842839      IF (ldcum(i)) THEN
    843         zdprho = (paph(i,k+1)-paph(i,k))/(rg*zrho(i))
    844         zentr = pentr(i)*pmfu(i, k+1)*zdprho
     840        zdprho = (paph(i, k + 1) - paph(i, k)) / (rg * zrho(i))
     841        zentr = pentr(i) * pmfu(i, k + 1) * zdprho
    845842        llo1 = k < kcbot(i)
    846843        IF (llo1) pde_u(i, k) = zentr
    847         zpmid = 0.5*(zpbot(i)+zptop(i))
    848         llo2 = llo1 .AND. ktype(i) == 2 .AND. (zpbot(i)-paph(i,k)<0.2E5 .OR. &
    849           paph(i,k)>zpmid)
     844        zpmid = 0.5 * (zpbot(i) + zptop(i))
     845        llo2 = llo1 .AND. ktype(i) == 2 .AND. (zpbot(i) - paph(i, k)<0.2E5 .OR. &
     846                paph(i, k)>zpmid)
    850847        IF (llo2) pen_u(i, k) = zentr
    851848        llo2 = llo1 .AND. (ktype(i)==1 .OR. ktype(i)==3) .AND. &
    852           (k>=max(klwmin(i),kctop0(i)+2) .OR. pap(i,k)>zpmid)
     849                (k>=max(klwmin(i), kctop0(i) + 2) .OR. pap(i, k)>zpmid)
    853850        IF (llo2) pen_u(i, k) = zentr
    854851        llo1 = pen_u(i, k) > 0. .AND. (ktype(i)==1 .OR. ktype(i)==2)
    855852        IF (llo1) THEN
    856           fact = 1. + 3.*(1.-min(1.,(zpbot(i)-pap(i,k))/1.5E4))
    857           zentr = zentr*fact
    858           pen_u(i, k) = pen_u(i, k)*fact
    859           pde_u(i, k) = pde_u(i, k)*fact
     853          fact = 1. + 3. * (1. - min(1., (zpbot(i) - pap(i, k)) / 1.5E4))
     854          zentr = zentr * fact
     855          pen_u(i, k) = pen_u(i, k) * fact
     856          pde_u(i, k) = pde_u(i, k) * fact
    860857        END IF
    861         IF (llo2 .AND. pqenh(i,k+1)>1.E-5) pen_u(i, k) = zentr + &
    862           max(pqte(i,k), 0.)/pqenh(i, k+1)*zrho(i)*zdprho
     858        IF (llo2 .AND. pqenh(i, k + 1)>1.E-5) pen_u(i, k) = zentr + &
     859                max(pqte(i, k), 0.) / pqenh(i, k + 1) * zrho(i) * zdprho
    863860      END IF
    864861    END DO
    … …  
    871868      IF (llflag(i)) THEN
    872869        IF (k<kcbot(i)) THEN
    873           zmftest = pmfu(i, k+1) + pen_u(i, k) - pde_u(i, k)
    874           zmfmax = min(zmftest, (paph(i,k)-paph(i,k-1))/(rg*pdtime))
    875           pen_u(i, k) = max(pen_u(i,k)-max(0.0,zmftest-zmfmax), 0.0)
     870          zmftest = pmfu(i, k + 1) + pen_u(i, k) - pde_u(i, k)
     871          zmfmax = min(zmftest, (paph(i, k) - paph(i, k - 1)) / (rg * pdtime))
     872          pen_u(i, k) = max(pen_u(i, k) - max(0.0, zmftest - zmfmax), 0.0)
    876873        END IF
    877         pde_u(i, k) = min(pde_u(i,k), 0.75*pmfu(i,k+1))
     874        pde_u(i, k) = min(pde_u(i, k), 0.75 * pmfu(i, k + 1))
    878875        ! calculer le flux de masse du niveau k a partir de celui du k+1
    879         pmfu(i, k) = pmfu(i, k+1) + pen_u(i, k) - pde_u(i, k)
     876        pmfu(i, k) = pmfu(i, k + 1) + pen_u(i, k) - pde_u(i, k)
    880877        ! calculer les valeurs Su, Qu et l du niveau k dans le panache
    881878        ! montant
    882         zqeen = pqenh(i, k+1)*pen_u(i, k)
    883         zseen = (rcpd*ptenh(i,k+1)+pgeoh(i,k+1))*pen_u(i, k)
    884         zscde = (rcpd*ptu(i,k+1)+pgeoh(i,k+1))*pde_u(i, k)
    885         zqude = pqu(i, k+1)*pde_u(i, k)
    886         plude(i, k) = plu(i, k+1)*pde_u(i, k)
    887         zmfusk = pmfus(i, k+1) + zseen - zscde
    888         zmfuqk = pmfuq(i, k+1) + zqeen - zqude
    889         zmfulk = pmful(i, k+1) - plude(i, k)
    890         plu(i, k) = zmfulk*(1./max(cmfcmin,pmfu(i,k)))
    891         pqu(i, k) = zmfuqk*(1./max(cmfcmin,pmfu(i,k)))
    892         ptu(i, k) = (zmfusk*(1./max(cmfcmin,pmfu(i,k)))-pgeoh(i,k))/rcpd
    893         ptu(i, k) = max(100., ptu(i,k))
    894         ptu(i, k) = min(400., ptu(i,k))
     879        zqeen = pqenh(i, k + 1) * pen_u(i, k)
     880        zseen = (rcpd * ptenh(i, k + 1) + pgeoh(i, k + 1)) * pen_u(i, k)
     881        zscde = (rcpd * ptu(i, k + 1) + pgeoh(i, k + 1)) * pde_u(i, k)
     882        zqude = pqu(i, k + 1) * pde_u(i, k)
     883        plude(i, k) = plu(i, k + 1) * pde_u(i, k)
     884        zmfusk = pmfus(i, k + 1) + zseen - zscde
     885        zmfuqk = pmfuq(i, k + 1) + zqeen - zqude
     886        zmfulk = pmful(i, k + 1) - plude(i, k)
     887        plu(i, k) = zmfulk * (1. / max(cmfcmin, pmfu(i, k)))
     888        pqu(i, k) = zmfuqk * (1. / max(cmfcmin, pmfu(i, k)))
     889        ptu(i, k) = (zmfusk * (1. / max(cmfcmin, pmfu(i, k))) - pgeoh(i, k)) / rcpd
     890        ptu(i, k) = max(100., ptu(i, k))
     891        ptu(i, k) = min(400., ptu(i, k))
    895892        zqold(i) = pqu(i, k)
    896893      ELSE
    … …  
    904901
    905902    iCALL = 1
    906     CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
    907 
    908     DO i = 1, klon
    909       IF (llflag(i) .AND. pqu(i,k)/=zqold(i)) THEN
     903    CALL flxadjtq(paph(1, k), ptu(1, k), pqu(1, k), llflag, icall)
     904
     905    DO i = 1, klon
     906      IF (llflag(i) .AND. pqu(i, k)/=zqold(i)) THEN
    910907        klab(i, k) = 2
    911908        plu(i, k) = plu(i, k) + zqold(i) - pqu(i, k)
    912         zbuo = ptu(i, k)*(1.+retv*pqu(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
    913           )
    914         IF (klab(i,k+1)==1) zbuo = zbuo + 0.5
    915         IF (zbuo>0. .AND. pmfu(i,k)>=0.1*pmfub(i)) THEN
     909        zbuo = ptu(i, k) * (1. + retv * pqu(i, k)) - ptenh(i, k) * (1. + retv * pqenh(i, k) &
     910                )
     911        IF (klab(i, k + 1)==1) zbuo = zbuo + 0.5
     912        IF (zbuo>0. .AND. pmfu(i, k)>=0.1 * pmfub(i)) THEN
    916913          kctop(i) = k
    917914          ldcum(i) = .TRUE.
    … …  
    919916          IF (ldland(i)) zdnoprc = zdland(i)
    920917          zprcon = cprcon
    921           IF ((zpbot(i)-paph(i,k))<zdnoprc) zprcon = 0.0
    922           zlnew = plu(i, k)/(1.+zprcon*(pgeoh(i,k)-pgeoh(i,k+1)))
    923           pdmfup(i, k) = max(0., (plu(i,k)-zlnew)*pmfu(i,k))
     918          IF ((zpbot(i) - paph(i, k))<zdnoprc) zprcon = 0.0
     919          zlnew = plu(i, k) / (1. + zprcon * (pgeoh(i, k) - pgeoh(i, k + 1)))
     920          pdmfup(i, k) = max(0., (plu(i, k) - zlnew) * pmfu(i, k))
    924921          plu(i, k) = zlnew
    925922        ELSE
    … …  
    931928    DO i = 1, klon
    932929      IF (llflag(i)) THEN
    933         pmful(i, k) = plu(i, k)*pmfu(i, k)
    934         pmfus(i, k) = (rcpd*ptu(i,k)+pgeoh(i,k))*pmfu(i, k)
    935         pmfuq(i, k) = pqu(i, k)*pmfu(i, k)
    936       END IF
    937     END DO
    938 
    939 480 END DO
     930        pmful(i, k) = plu(i, k) * pmfu(i, k)
     931        pmfus(i, k) = (rcpd * ptu(i, k) + pgeoh(i, k)) * pmfu(i, k)
     932        pmfuq(i, k) = pqu(i, k) * pmfu(i, k)
     933      END IF
     934    END DO
     935
     936  480 END DO
    940937  ! ----------------------------------------------------------------------
    941938  ! DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
    … …  
    945942  ! ----------------------------------------------------------------------
    946943  DO i = 1, klon
    947     IF (kctop(i)==klev-1) ldcum(i) = .FALSE.
     944    IF (kctop(i)==klev - 1) ldcum(i) = .FALSE.
    948945    kcbot(i) = max(kcbot(i), kctop(i))
    949946  END DO
    … …  
    961958    IF (ldcum(i)) THEN
    962959      k = kctop(i) - 1
    963       pde_u(i, k) = (1.-cmfctop)*pmfu(i, k+1)
    964       plude(i, k) = pde_u(i, k)*plu(i, k+1)
    965       pmfu(i, k) = pmfu(i, k+1) - pde_u(i, k)
     960      pde_u(i, k) = (1. - cmfctop) * pmfu(i, k + 1)
     961      plude(i, k) = pde_u(i, k) * plu(i, k + 1)
     962      pmfu(i, k) = pmfu(i, k + 1) - pde_u(i, k)
    966963      zlnew = plu(i, k)
    967       pdmfup(i, k) = max(0., (plu(i,k)-zlnew)*pmfu(i,k))
     964      pdmfup(i, k) = max(0., (plu(i, k) - zlnew) * pmfu(i, k))
    968965      plu(i, k) = zlnew
    969       pmfus(i, k) = (rcpd*ptu(i,k)+pgeoh(i,k))*pmfu(i, k)
    970       pmfuq(i, k) = pqu(i, k)*pmfu(i, k)
    971       pmful(i, k) = plu(i, k)*pmfu(i, k)
    972       plude(i, k-1) = pmful(i, k)
     966      pmfus(i, k) = (rcpd * ptu(i, k) + pgeoh(i, k)) * pmfu(i, k)
     967      pmfuq(i, k) = pqu(i, k) * pmfu(i, k)
     968      pmful(i, k) = plu(i, k) * pmfu(i, k)
     969      plude(i, k - 1) = pmful(i, k)
    973970    END IF
    974971  END DO
    975972
    976 800 CONTINUE
     973  800 CONTINUE
    977974
    978975END SUBROUTINE flxasc
    979976SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap, paph, ldland, &
    980     pgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum, pmfu, pmfd, pmfus, &
    981     pmfds, pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp, pten, prfl, psfl, &
    982     pdpmel, ktopm2, pmflxr, pmflxs)
     977        pgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum, pmfu, pmfd, pmfus, &
     978        pmfds, pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp, pten, prfl, psfl, &
     979        pdpmel, ktopm2, pmflxr, pmflxs)
    983980  USE dimphy
    984981  USE lmdz_print_control, ONLY: prt_level
     982  USE lmdz_YOECUMF
     983
    985984  IMPLICIT NONE
    986985  ! ----------------------------------------------------------------------
    … …  
    990989  include "YOMCST.h"
    991990  include "YOETHF.h"
    992   include "YOECUMF.h"
    993991
    994992  REAL cevapcu(klon, klev)
    … …  
    996994  REAL pqen(klon, klev), pqenh(klon, klev), pqsen(klon, klev)
    997995  REAL pten(klon, klev), ptenh(klon, klev)
    998   REAL paph(klon, klev+1), pgeoh(klon, klev)
     996  REAL paph(klon, klev + 1), pgeoh(klon, klev)
    999997
    1000998  REAL pap(klon, klev)
    … …  
    10111009  REAL pdmfdp(klon, klev), maxpdmfdp(klon, klev)
    10121010  REAL prfl(klon), psfl(klon)
    1013   REAL pmflxr(klon, klev+1), pmflxs(klon, klev+1)
     1011  REAL pmflxr(klon, klev + 1), pmflxs(klon, klev + 1)
    10141012  INTEGER kcbot(klon), kctop(klon), ktype(klon)
    10151013  LOGICAL ldland(klon), ldcum(klon)
    … …  
    10281026  DO k = 1, klev
    10291027    DO i = 1, klon
    1030       cevapcu(i, k) = 1.93E-6*261.*sqrt(1.E3/(38.3*0.293)*sqrt(0.5*(paph(i,k) &
    1031         +paph(i,k+1))/paph(i,klev+1)))*0.5/rg
     1028      cevapcu(i, k) = 1.93E-6 * 261. * sqrt(1.E3 / (38.3 * 0.293) * sqrt(0.5 * (paph(i, k) &
     1029              + paph(i, k + 1)) / paph(i, klev + 1))) * 0.5 / rg
    10321030    END DO
    10331031  END DO
    … …  
    10351033  ! SPECIFY CONSTANTS
    10361034
    1037   zcons1 = rcpd/(rlmlt*rg*pdtime)
    1038   zcons2 = 1./(rg*pdtime)
     1035  zcons1 = rcpd / (rlmlt * rg * pdtime)
     1036  zcons2 = 1. / (rg * pdtime)
    10391037  zcucov = 0.05
    10401038  ztmelp2 = rtt + 2.
    … …  
    10521050  DO k = ktopm2, klev
    10531051    DO i = 1, klon
    1054       IF (ldcum(i) .AND. k>=kctop(i)-1) THEN
    1055         pmfus(i, k) = pmfus(i, k) - pmfu(i, k)*(rcpd*ptenh(i,k)+pgeoh(i,k))
    1056         pmfuq(i, k) = pmfuq(i, k) - pmfu(i, k)*pqenh(i, k)
     1052      IF (ldcum(i) .AND. k>=kctop(i) - 1) THEN
     1053        pmfus(i, k) = pmfus(i, k) - pmfu(i, k) * (rcpd * ptenh(i, k) + pgeoh(i, k))
     1054        pmfuq(i, k) = pmfuq(i, k) - pmfu(i, k) * pqenh(i, k)
    10571055        zdp = 1.5E4
    10581056        IF (ldland(i)) zdp = 3.E4
    … …  
    10621060        ! evaporee dans l'environnement)
    10631061
    1064         IF (paph(i,kcbot(i))-paph(i,kctop(i))>=zdp .AND. pqen(i,k-1)>0.8* &
    1065           pqsen(i,k-1)) pdmfup(i, k-1) = pdmfup(i, k-1) + plude(i, k-1)
     1062        IF (paph(i, kcbot(i)) - paph(i, kctop(i))>=zdp .AND. pqen(i, k - 1)>0.8 * &
     1063                pqsen(i, k - 1)) pdmfup(i, k - 1) = pdmfup(i, k - 1) + plude(i, k - 1)
    10661064
    10671065        IF (lddraf(i) .AND. k>=kdtop(i)) THEN
    1068           pmfds(i, k) = pmfds(i, k) - pmfd(i, k)*(rcpd*ptenh(i,k)+pgeoh(i,k))
    1069           pmfdq(i, k) = pmfdq(i, k) - pmfd(i, k)*pqenh(i, k)
     1066          pmfds(i, k) = pmfds(i, k) - pmfd(i, k) * (rcpd * ptenh(i, k) + pgeoh(i, k))
     1067          pmfdq(i, k) = pmfdq(i, k) - pmfd(i, k) * pqenh(i, k)
    10701068        ELSE
    10711069          pmfd(i, k) = 0.
    10721070          pmfds(i, k) = 0.
    10731071          pmfdq(i, k) = 0.
    1074           pdmfdp(i, k-1) = 0.
     1072          pdmfdp(i, k - 1) = 0.
    10751073        END IF
    10761074      ELSE
    … …  
    10791077        pmfuq(i, k) = 0.
    10801078        pmful(i, k) = 0.
    1081         pdmfup(i, k-1) = 0.
    1082         plude(i, k-1) = 0.
     1079        pdmfup(i, k - 1) = 0.
     1080        plude(i, k - 1) = 0.
    10831081        pmfd(i, k) = 0.
    10841082        pmfds(i, k) = 0.
    10851083        pmfdq(i, k) = 0.
    1086         pdmfdp(i, k-1) = 0.
     1084        pdmfdp(i, k - 1) = 0.
    10871085      END IF
    10881086    END DO
    … …  
    10931091      IF (ldcum(i) .AND. k>kcbot(i)) THEN
    10941092        ikb = kcbot(i)
    1095         zzp = ((paph(i,klev+1)-paph(i,k))/(paph(i,klev+1)-paph(i,ikb)))
     1093        zzp = ((paph(i, klev + 1) - paph(i, k)) / (paph(i, klev + 1) - paph(i, ikb)))
    10961094        IF (ktype(i)==3) zzp = zzp**2
    1097         pmfu(i, k) = pmfu(i, ikb)*zzp
    1098         pmfus(i, k) = pmfus(i, ikb)*zzp
    1099         pmfuq(i, k) = pmfuq(i, ikb)*zzp
    1100         pmful(i, k) = pmful(i, ikb)*zzp
     1095        pmfu(i, k) = pmfu(i, ikb) * zzp
     1096        pmfus(i, k) = pmfus(i, ikb) * zzp
     1097        pmfuq(i, k) = pmfuq(i, ikb) * zzp
     1098        pmful(i, k) = pmful(i, ikb) * zzp
    11011099      END IF
    11021100    END DO
    … …  
    11161114    DO i = 1, klon
    11171115      IF (ldcum(i)) THEN
    1118         IF (pmflxs(i,k)>0.0 .AND. pten(i,k)>ztmelp2) THEN
    1119           zfac = zcons1*(paph(i,k+1)-paph(i,k))
    1120           zsnmlt = min(pmflxs(i,k), zfac*(pten(i,k)-ztmelp2))
     1116        IF (pmflxs(i, k)>0.0 .AND. pten(i, k)>ztmelp2) THEN
     1117          zfac = zcons1 * (paph(i, k + 1) - paph(i, k))
     1118          zsnmlt = min(pmflxs(i, k), zfac * (pten(i, k) - ztmelp2))
    11211119          pdpmel(i, k) = zsnmlt
    1122           ztmsmlt = pten(i, k) - zsnmlt/zfac
    1123           zdelta = max(0., sign(1.,rtt-ztmsmlt))
    1124           zqsat = r2es*foeew(ztmsmlt, zdelta)/pap(i, k)
     1120          ztmsmlt = pten(i, k) - zsnmlt / zfac
     1121          zdelta = max(0., sign(1., rtt - ztmsmlt))
     1122          zqsat = r2es * foeew(ztmsmlt, zdelta) / pap(i, k)
    11251123          zqsat = min(0.5, zqsat)
    1126           zqsat = zqsat/(1.-retv*zqsat)
     1124          zqsat = zqsat / (1. - retv * zqsat)
    11271125          pqsen(i, k) = zqsat
    11281126        END IF
    1129         IF (pten(i,k)>rtt) THEN
    1130           pmflxr(i, k+1) = pmflxr(i, k) + pdmfup(i, k) + pdmfdp(i, k) + &
    1131             pdpmel(i, k)
    1132           pmflxs(i, k+1) = pmflxs(i, k) - pdpmel(i, k)
     1127        IF (pten(i, k)>rtt) THEN
     1128          pmflxr(i, k + 1) = pmflxr(i, k) + pdmfup(i, k) + pdmfdp(i, k) + &
     1129                  pdpmel(i, k)
     1130          pmflxs(i, k + 1) = pmflxs(i, k) - pdpmel(i, k)
    11331131        ELSE
    1134           pmflxs(i, k+1) = pmflxs(i, k) + pdmfup(i, k) + pdmfdp(i, k)
    1135           pmflxr(i, k+1) = pmflxr(i, k)
     1132          pmflxs(i, k + 1) = pmflxs(i, k) + pdmfup(i, k) + pdmfdp(i, k)
     1133          pmflxr(i, k + 1) = pmflxr(i, k)
    11361134        END IF
    11371135        ! si la precipitation est negative, on ajuste le plux du
    11381136        ! panache descendant pour eliminer la negativite
    1139         IF ((pmflxr(i,k+1)+pmflxs(i,k+1))<0.0) THEN
     1137        IF ((pmflxr(i, k + 1) + pmflxs(i, k + 1))<0.0) THEN
    11401138          pdmfdp(i, k) = -pmflxr(i, k) - pmflxs(i, k) - pdmfup(i, k)
    1141           pmflxr(i, k+1) = 0.0
    1142           pmflxs(i, k+1) = 0.0
     1139          pmflxr(i, k + 1) = 0.0
     1140          pmflxs(i, k + 1) = 0.0
    11431141          pdpmel(i, k) = 0.0
    11441142        END IF
    … …  
    11741172        zrfl = pmflxr(i, k) + pmflxs(i, k)
    11751173        IF (zrfl>1.0E-20) THEN
    1176           zrnew = (max(0.,sqrt(zrfl/zcucov)-cevapcu(i, &
    1177             k)*(paph(i,k+1)-paph(i,k))*max(0.,pqsen(i,k)-pqen(i,k))))**2* &
    1178             zcucov
    1179           zrmin = zrfl - zcucov*max(0., 0.8*pqsen(i,k)-pqen(i,k))*zcons2*( &
    1180             paph(i,k+1)-paph(i,k))
     1174          zrnew = (max(0., sqrt(zrfl / zcucov) - cevapcu(i, &
     1175                  k) * (paph(i, k + 1) - paph(i, k)) * max(0., pqsen(i, k) - pqen(i, k))))**2 * &
     1176                  zcucov
     1177          zrmin = zrfl - zcucov * max(0., 0.8 * pqsen(i, k) - pqen(i, k)) * zcons2 * (&
     1178                  paph(i, k + 1) - paph(i, k))
    11811179          zrnew = max(zrnew, zrmin)
    11821180          zrfln = max(zrnew, 0.)
    1183           zdrfl = min(0., zrfln-zrfl)
     1181          zdrfl = min(0., zrfln - zrfl)
    11841182          ! jq At least the amount of precipiation needed to feed the
    11851183          ! downdraft
    … …  
    11871185          ! can't
    11881186          ! jq be evaporated (surely the evaporation can't be positive):
    1189           zdrfl = max(zdrfl, min(-pmflxr(i,k)-pmflxs(i,k)-maxpdmfdp(i, &
    1190             k),0.0))
     1187          zdrfl = max(zdrfl, min(-pmflxr(i, k) - pmflxs(i, k) - maxpdmfdp(i, &
     1188                  k), 0.0))
    11911189          ! jq End of insertion
    11921190
    1193           zdenom = 1.0/max(1.0E-20, pmflxr(i,k)+pmflxs(i,k))
    1194           IF (pten(i,k)>rtt) THEN
     1191          zdenom = 1.0 / max(1.0E-20, pmflxr(i, k) + pmflxs(i, k))
     1192          IF (pten(i, k)>rtt) THEN
    11951193            zpdr = pdmfdp(i, k)
    11961194            zpds = 0.0
    … …  
    11991197            zpds = pdmfdp(i, k)
    12001198          END IF
    1201           pmflxr(i, k+1) = pmflxr(i, k) + zpdr + pdpmel(i, k) + &
    1202             zdrfl*pmflxr(i, k)*zdenom
    1203           pmflxs(i, k+1) = pmflxs(i, k) + zpds - pdpmel(i, k) + &
    1204             zdrfl*pmflxs(i, k)*zdenom
     1199          pmflxr(i, k + 1) = pmflxr(i, k) + zpdr + pdpmel(i, k) + &
     1200                  zdrfl * pmflxr(i, k) * zdenom
     1201          pmflxs(i, k + 1) = pmflxs(i, k) + zpds - pdpmel(i, k) + &
     1202                  zdrfl * pmflxs(i, k) * zdenom
    12051203          pdmfup(i, k) = pdmfup(i, k) + zdrfl
    12061204        ELSE
    1207           pmflxr(i, k+1) = 0.0
    1208           pmflxs(i, k+1) = 0.0
     1205          pmflxr(i, k + 1) = 0.0
     1206          pmflxs(i, k + 1) = 0.0
    12091207          pdmfdp(i, k) = 0.0
    12101208          pdpmel(i, k) = 0.0
    12111209        END IF
    1212         IF (pmflxr(i,k)+pmflxs(i,k)<-1.E-26 .AND. prt_level>=1) WRITE (*, *) &
    1213           'precip. < 1e-16 ', pmflxr(i, k) + pmflxs(i, k)
    1214       END IF
    1215     END DO
    1216   END DO
    1217 
    1218   DO i = 1, klon
    1219     prfl(i) = pmflxr(i, klev+1)
    1220     psfl(i) = pmflxs(i, klev+1)
    1221   END DO
    1222 
     1210        IF (pmflxr(i, k) + pmflxs(i, k)<-1.E-26 .AND. prt_level>=1) WRITE (*, *) &
     1211                'precip. < 1e-16 ', pmflxr(i, k) + pmflxs(i, k)
     1212      END IF
     1213    END DO
     1214  END DO
     1215
     1216  DO i = 1, klon
     1217    prfl(i) = pmflxr(i, klev + 1)
     1218    psfl(i) = pmflxs(i, klev + 1)
     1219  END DO
    12231220
    12241221END SUBROUTINE flxflux
    12251222SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten, pmfus, pmfds, pmfuq, &
    1226     pmfdq, pmful, pdmfup, pdmfdp, pdpmel, dt_con, dq_con)
     1223        pmfdq, pmful, pdmfup, pdmfdp, pdpmel, dt_con, dq_con)
    12271224  USE dimphy
     1225  USE lmdz_YOECUMF
     1226
    12281227  IMPLICIT NONE
    12291228  ! ----------------------------------------------------------------------
    … …  
    12321231  include "YOMCST.h"
    12331232  include "YOETHF.h"
    1234   include "YOECUMF.h"
    12351233  ! -----------------------------------------------------------------
    12361234  LOGICAL llo1
    12371235
    1238   REAL pten(klon, klev), paph(klon, klev+1)
     1236  REAL pten(klon, klev), paph(klon, klev + 1)
    12391237  REAL pmfus(klon, klev), pmfuq(klon, klev), pmful(klon, klev)
    12401238  REAL pmfds(klon, klev), pmfdq(klon, klev)
    … …  
    12541252    DO i = 1, klon
    12551253      IF (ldcum(i)) THEN
    1256         llo1 = (pten(i,k)-rtt) > 0.
     1254        llo1 = (pten(i, k) - rtt) > 0.
    12571255        zalv = rlstt
    12581256        IF (llo1) zalv = rlvtt
    1259         zdtdt = rg/(paph(i,k+1)-paph(i,k))/rcpd*(pmfus(i,k+1)-pmfus(i,k)+ &
    1260           pmfds(i,k+1)-pmfds(i,k)-rlmlt*pdpmel(i,k)-zalv*(pmful(i, &
    1261           k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k)))
     1257        zdtdt = rg / (paph(i, k + 1) - paph(i, k)) / rcpd * (pmfus(i, k + 1) - pmfus(i, k) + &
     1258                pmfds(i, k + 1) - pmfds(i, k) - rlmlt * pdpmel(i, k) - zalv * (pmful(i, &
     1259                k + 1) - pmful(i, k) - pdmfup(i, k) - pdmfdp(i, k)))
    12621260        dt_con(i, k) = zdtdt
    1263         zdqdt = rg/(paph(i,k+1)-paph(i,k))*(pmfuq(i,k+1)-pmfuq(i,k)+pmfdq(i,k &
    1264           +1)-pmfdq(i,k)+pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
     1261        zdqdt = rg / (paph(i, k + 1) - paph(i, k)) * (pmfuq(i, k + 1) - pmfuq(i, k) + pmfdq(i, k &
     1262                + 1) - pmfdq(i, k) + pmful(i, k + 1) - pmful(i, k) - pdmfup(i, k) - pdmfdp(i, k))
    12651263        dq_con(i, k) = zdqdt
    12661264      END IF
    … …  
    12711269  DO i = 1, klon
    12721270    IF (ldcum(i)) THEN
    1273       llo1 = (pten(i,k)-rtt) > 0.
     1271      llo1 = (pten(i, k) - rtt) > 0.
    12741272      zalv = rlstt
    12751273      IF (llo1) zalv = rlvtt
    1276       zdtdt = -rg/(paph(i,k+1)-paph(i,k))/rcpd*(pmfus(i,k)+pmfds(i,k)+rlmlt* &
    1277         pdpmel(i,k)-zalv*(pmful(i,k)+pdmfup(i,k)+pdmfdp(i,k)))
     1274      zdtdt = -rg / (paph(i, k + 1) - paph(i, k)) / rcpd * (pmfus(i, k) + pmfds(i, k) + rlmlt * &
     1275              pdpmel(i, k) - zalv * (pmful(i, k) + pdmfup(i, k) + pdmfdp(i, k)))
    12781276      dt_con(i, k) = zdtdt
    1279       zdqdt = -rg/(paph(i,k+1)-paph(i,k))*(pmfuq(i,k)+pmfdq(i,k)+pmful(i,k)+ &
    1280         pdmfup(i,k)+pdmfdp(i,k))
     1277      zdqdt = -rg / (paph(i, k + 1) - paph(i, k)) * (pmfuq(i, k) + pmfdq(i, k) + pmful(i, k) + &
     1278              pdmfup(i, k) + pdmfdp(i, k))
    12811279      dq_con(i, k) = zdqdt
    12821280    END IF
    12831281  END DO
    12841282
    1285 
    12861283END SUBROUTINE flxdtdq
    12871284SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu, ldcum, kcbot, kctop, &
    1288     pmfub, prfl, ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf)
     1285        pmfub, prfl, ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf)
    12891286  USE dimphy
     1287  USE lmdz_YOECUMF
     1288
    12901289  IMPLICIT NONE
    12911290
    … …  
    13071306  include "YOMCST.h"
    13081307  include "YOETHF.h"
    1309   include "YOECUMF.h"
    13101308
    13111309  REAL ptenh(klon, klev)
    13121310  REAL pqenh(klon, klev)
    1313   REAL pgeoh(klon, klev), paph(klon, klev+1)
     1311  REAL pgeoh(klon, klev), paph(klon, klev + 1)
    13141312  REAL ptu(klon, klev), pqu(klon, klev)
    13151313  REAL pmfub(klon)
    … …  
    13541352      zqenwb(i, k) = pqenh(i, k)
    13551353      llo2(i) = ldcum(i) .AND. prfl(i) > 0. .AND. .NOT. lddraf(i) .AND. &
    1356         (k<kcbot(i) .AND. k>kctop(i))
     1354              (k<kcbot(i) .AND. k>kctop(i))
    13571355      IF (llo2(i)) is = is + 1
    13581356    END DO
    … …  
    13601358
    13611359    iCALL = 2
    1362     CALL flxadjtq(paph(1,k), ztenwb(1,k), zqenwb(1,k), llo2, icall)
     1360    CALL flxadjtq(paph(1, k), ztenwb(1, k), zqenwb(1, k), llo2, icall)
    13631361
    13641362    ! ----------------------------------------------------------------------
    … …  
    13691367    DO i = 1, klon
    13701368      IF (llo2(i)) THEN
    1371         zttest = 0.5*(ptu(i,k)+ztenwb(i,k))
    1372         zqtest = 0.5*(pqu(i,k)+zqenwb(i,k))
    1373         zbuo = zttest*(1.+retv*zqtest) - ptenh(i, k)*(1.+retv*pqenh(i,k))
     1369        zttest = 0.5 * (ptu(i, k) + ztenwb(i, k))
     1370        zqtest = 0.5 * (pqu(i, k) + zqenwb(i, k))
     1371        zbuo = zttest * (1. + retv * zqtest) - ptenh(i, k) * (1. + retv * pqenh(i, k))
    13741372        zcond(i) = pqenh(i, k) - zqenwb(i, k)
    1375         zmftop = -cmfdeps*pmfub(i)
    1376         IF (zbuo<0. .AND. prfl(i)>10.*zmftop*zcond(i)) THEN
     1373        zmftop = -cmfdeps * pmfub(i)
     1374        IF (zbuo<0. .AND. prfl(i)>10. * zmftop * zcond(i)) THEN
    13771375          kdtop(i) = k
    13781376          lddraf(i) = .TRUE.
    … …  
    13801378          pqd(i, k) = zqtest
    13811379          pmfd(i, k) = zmftop
    1382           pmfds(i, k) = pmfd(i, k)*(rcpd*ptd(i,k)+pgeoh(i,k))
    1383           pmfdq(i, k) = pmfd(i, k)*pqd(i, k)
    1384           pdmfdp(i, k-1) = -0.5*pmfd(i, k)*zcond(i)
    1385           prfl(i) = prfl(i) + pdmfdp(i, k-1)
     1380          pmfds(i, k) = pmfd(i, k) * (rcpd * ptd(i, k) + pgeoh(i, k))
     1381          pmfdq(i, k) = pmfd(i, k) * pqd(i, k)
     1382          pdmfdp(i, k - 1) = -0.5 * pmfd(i, k) * zcond(i)
     1383          prfl(i) = prfl(i) + pdmfdp(i, k - 1)
    13861384        END IF
    13871385      END IF
    13881386    END DO
    13891387
    1390 290 END DO
    1391 
     1388  290 END DO
    13921389
    13931390END SUBROUTINE flxdlfs
    13941391SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl, ptd, pqd, pmfd, pmfds, &
    1395     pmfdq, pdmfdp, lddraf, pen_d, pde_d)
     1392        pmfdq, pdmfdp, lddraf, pen_d, pde_d)
    13961393  USE dimphy
     1394  USE lmdz_YOECUMF
     1395
    13971396  IMPLICIT NONE
    13981397
    … …  
    14141413  include "YOMCST.h"
    14151414  include "YOETHF.h"
    1416   include "YOECUMF.h"
    14171415
    14181416  REAL ptenh(klon, klev), pqenh(klon, klev)
    1419   REAL pgeoh(klon, klev), paph(klon, klev+1)
     1417  REAL pgeoh(klon, klev), paph(klon, klev + 1)
    14201418
    14211419  REAL ptd(klon, klev), pqd(klon, klev)
    … …  
    14431441    is = 0
    14441442    DO i = 1, klon
    1445       llo2(i) = lddraf(i) .AND. pmfd(i, k-1) < 0.
     1443      llo2(i) = lddraf(i) .AND. pmfd(i, k - 1) < 0.
    14461444      IF (llo2(i)) is = is + 1
    14471445    END DO
    … …  
    14501448    DO i = 1, klon
    14511449      IF (llo2(i)) THEN
    1452         zentr = entrdd*pmfd(i, k-1)*rd*ptenh(i, k-1)/(rg*paph(i,k-1))* &
    1453           (paph(i,k)-paph(i,k-1))
     1450        zentr = entrdd * pmfd(i, k - 1) * rd * ptenh(i, k - 1) / (rg * paph(i, k - 1)) * &
     1451                (paph(i, k) - paph(i, k - 1))
    14541452        pen_d(i, k) = zentr
    14551453        pde_d(i, k) = zentr
    … …  
    14621460        IF (llo2(i)) THEN
    14631461          pen_d(i, k) = 0.
    1464           pde_d(i, k) = pmfd(i, itopde)*(paph(i,k)-paph(i,k-1))/ &
    1465             (paph(i,klev+1)-paph(i,itopde))
     1462          pde_d(i, k) = pmfd(i, itopde) * (paph(i, k) - paph(i, k - 1)) / &
     1463                  (paph(i, klev + 1) - paph(i, itopde))
    14661464        END IF
    14671465      END DO
    … …  
    14701468    DO i = 1, klon
    14711469      IF (llo2(i)) THEN
    1472         pmfd(i, k) = pmfd(i, k-1) + pen_d(i, k) - pde_d(i, k)
    1473         zseen = (rcpd*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i, k)
    1474         zqeen = pqenh(i, k-1)*pen_d(i, k)
    1475         zsdde = (rcpd*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i, k)
    1476         zqdde = pqd(i, k-1)*pde_d(i, k)
    1477         zmfdsk = pmfds(i, k-1) + zseen - zsdde
    1478         zmfdqk = pmfdq(i, k-1) + zqeen - zqdde
    1479         pqd(i, k) = zmfdqk*(1./min(-cmfcmin,pmfd(i,k)))
    1480         ptd(i, k) = (zmfdsk*(1./min(-cmfcmin,pmfd(i,k)))-pgeoh(i,k))/rcpd
    1481         ptd(i, k) = min(400., ptd(i,k))
    1482         ptd(i, k) = max(100., ptd(i,k))
     1470        pmfd(i, k) = pmfd(i, k - 1) + pen_d(i, k) - pde_d(i, k)
     1471        zseen = (rcpd * ptenh(i, k - 1) + pgeoh(i, k - 1)) * pen_d(i, k)
     1472        zqeen = pqenh(i, k - 1) * pen_d(i, k)
     1473        zsdde = (rcpd * ptd(i, k - 1) + pgeoh(i, k - 1)) * pde_d(i, k)
     1474        zqdde = pqd(i, k - 1) * pde_d(i, k)
     1475        zmfdsk = pmfds(i, k - 1) + zseen - zsdde
     1476        zmfdqk = pmfdq(i, k - 1) + zqeen - zqdde
     1477        pqd(i, k) = zmfdqk * (1. / min(-cmfcmin, pmfd(i, k)))
     1478        ptd(i, k) = (zmfdsk * (1. / min(-cmfcmin, pmfd(i, k))) - pgeoh(i, k)) / rcpd
     1479        ptd(i, k) = min(400., ptd(i, k))
     1480        ptd(i, k) = max(100., ptd(i, k))
    14831481        zcond(i) = pqd(i, k)
    14841482      END IF
    … …  
    14861484
    14871485    iCALL = 2
    1488     CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)
     1486    CALL flxadjtq(paph(1, k), ptd(1, k), pqd(1, k), llo2, icall)
    14891487
    14901488    DO i = 1, klon
    14911489      IF (llo2(i)) THEN
    14921490        zcond(i) = zcond(i) - pqd(i, k)
    1493         zbuo = ptd(i, k)*(1.+retv*pqd(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
    1494           )
    1495         llo1 = zbuo < 0. .AND. (prfl(i)-pmfd(i,k)*zcond(i)>0.)
     1491        zbuo = ptd(i, k) * (1. + retv * pqd(i, k)) - ptenh(i, k) * (1. + retv * pqenh(i, k) &
     1492                )
     1493        llo1 = zbuo < 0. .AND. (prfl(i) - pmfd(i, k) * zcond(i)>0.)
    14961494        IF (.NOT. llo1) pmfd(i, k) = 0.0
    1497         pmfds(i, k) = (rcpd*ptd(i,k)+pgeoh(i,k))*pmfd(i, k)
    1498         pmfdq(i, k) = pqd(i, k)*pmfd(i, k)
    1499         zdmfdp = -pmfd(i, k)*zcond(i)
    1500         pdmfdp(i, k-1) = zdmfdp
     1495        pmfds(i, k) = (rcpd * ptd(i, k) + pgeoh(i, k)) * pmfd(i, k)
     1496        pmfdq(i, k) = pqd(i, k) * pmfd(i, k)
     1497        zdmfdp = -pmfd(i, k) * zcond(i)
     1498        pdmfdp(i, k - 1) = zdmfdp
    15011499        prfl(i) = prfl(i) + zdmfdp
    15021500      END IF
    15031501    END DO
    15041502
    1505 180 END DO
     1503  180 END DO
    15061504
    15071505END SUBROUTINE flxddraf
    … …  
    15301528  include "FCTTRE.h"
    15311529
    1532   z5alvcp = r5les*rlvtt/rcpd
    1533   z5alscp = r5ies*rlstt/rcpd
    1534   zalvdcp = rlvtt/rcpd
    1535   zalsdcp = rlstt/rcpd
    1536 
     1530  z5alvcp = r5les * rlvtt / rcpd
     1531  z5alscp = r5ies * rlstt / rcpd
     1532  zalvdcp = rlvtt / rcpd
     1533  zalsdcp = rlstt / rcpd
    15371534
    15381535  DO i = 1, klon
    … …  
    15421539  DO i = 1, klon
    15431540    IF (ldflag(i)) THEN
    1544       zdelta = max(0., sign(1.,rtt-pt(i)))
    1545       zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
    1546       zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
    1547       zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
     1541      zdelta = max(0., sign(1., rtt - pt(i)))
     1542      zcvm5 = z5alvcp * (1. - zdelta) + zdelta * z5alscp
     1543      zldcp = zalvdcp * (1. - zdelta) + zdelta * zalsdcp
     1544      zqsat = r2es * foeew(pt(i), zdelta) / pp(i)
    15481545      zqsat = min(0.5, zqsat)
    1549       zcor = 1./(1.-retv*zqsat)
    1550       zqsat = zqsat*zcor
    1551       zcond(i) = (pq(i)-zqsat)/(1.+foede(pt(i),zdelta,zcvm5,zqsat,zcor))
     1546      zcor = 1. / (1. - retv * zqsat)
     1547      zqsat = zqsat * zcor
     1548      zcond(i) = (pq(i) - zqsat) / (1. + foede(pt(i), zdelta, zcvm5, zqsat, zcor))
    15521549      IF (kcall==1) zcond(i) = max(zcond(i), 0.)
    15531550      IF (kcall==2) zcond(i) = min(zcond(i), 0.)
    1554       pt(i) = pt(i) + zldcp*zcond(i)
     1551      pt(i) = pt(i) + zldcp * zcond(i)
    15551552      pq(i) = pq(i) - zcond(i)
    15561553    END IF
    … …  
    15651562  DO i = 1, klon
    15661563    IF (ldflag(i) .AND. zcond(i)/=0.) THEN
    1567       zdelta = max(0., sign(1.,rtt-pt(i)))
    1568       zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
    1569       zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
    1570       zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
     1564      zdelta = max(0., sign(1., rtt - pt(i)))
     1565      zcvm5 = z5alvcp * (1. - zdelta) + zdelta * z5alscp
     1566      zldcp = zalvdcp * (1. - zdelta) + zdelta * zalsdcp
     1567      zqsat = r2es * foeew(pt(i), zdelta) / pp(i)
    15711568      zqsat = min(0.5, zqsat)
    1572       zcor = 1./(1.-retv*zqsat)
    1573       zqsat = zqsat*zcor
    1574       zcond1 = (pq(i)-zqsat)/(1.+foede(pt(i),zdelta,zcvm5,zqsat,zcor))
    1575       pt(i) = pt(i) + zldcp*zcond1
     1569      zcor = 1. / (1. - retv * zqsat)
     1570      zqsat = zqsat * zcor
     1571      zcond1 = (pq(i) - zqsat) / (1. + foede(pt(i), zdelta, zcvm5, zqsat, zcor))
     1572      pt(i) = pt(i) + zldcp * zcond1
    15761573      pq(i) = pq(i) - zcond1
    15771574    END IF
    15781575  END DO
    15791576
    1580 230 CONTINUE
     1577  230 CONTINUE
    15811578
    15821579END SUBROUTINE flxadjtq
    15831580SUBROUTINE flxsetup
     1581  USE lmdz_YOECUMF
     1582
    15841583  IMPLICIT NONE
    15851584
    15861585  ! THIS ROUTINE DEFINES DISPOSABLE PARAMETERS FOR MASSFLUX SCHEME
    1587 
    1588   include "YOECUMF.h"
    15891586
    15901587  entrpen = 1.0E-4 ! ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
    … …  
    16051602  lmfdudv = .TRUE.
    16061603
    1607 
    16081604END SUBROUTINE flxsetup

  • LMDZ6/branches/Amaury_dev/libf/phylmd/cv_driver.F90

    r5141 r5142  
    1414  USE lmdz_cv30, ONLY: cv30_param, cv30_prelim, cv30_feed, cv30_undilute1, cv30_trigger, cv30_compress, cv30_undilute2, &
    1515          cv30_closure, cv30_epmax_fn_cape, cv30_mixing, cv30_unsat, cv30_yield, cv30_tracer, cv30_uncompress
     16  USE lmdz_cv, ONLY: cv_param, cv_prelim, cv_feed, cv_undilute1, cv_trigger, cv_compress, &
     17          cv_undilute2, cv_closure, cv_mixing, cv_unsat, cv_yield, cv_uncompress
    1618
    1719  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/phylmd/cva_driver.F90

    r5117 r5142  
    4242  USE add_phys_tend_mod, ONLY: fl_cor_ebil
    4343  USE lmdz_abort_physic, ONLY: abort_physic
     44  USE lmdz_cv, ONLY: cv_param, cv_prelim, cv_feed, cv_undilute1, cv_trigger, cv_compress, &
     45          cv_undilute2, cv_closure, cv_mixing, cv_unsat, cv_yield, cv_uncompress
     46
    4447  IMPLICIT NONE
    4548

  • LMDZ6/branches/Amaury_dev/libf/phylmd/cvltr.F90

    r5140 r5142  
    1414  USE infotrac_phy, ONLY: nbtr
    1515  USE lmdz_conema3
     16  USE lmdz_YOECUMF
    1617
    1718  IMPLICIT NONE
    … …  
    2324
    2425  include "YOMCST.h"
    25   include "YOECUMF.h"
    2626
    2727! Entree

  • LMDZ6/branches/Amaury_dev/libf/phylmd/cvltr_noscav.F90

    r5117 r5142  
    55  USE dimphy
    66  USE infotrac_phy, ONLY: nbtr
     7  USE lmdz_YOECUMF
     8
    79  IMPLICIT NONE
    810!=====================================================================
    … …  
    1113!=====================================================================
    1214  include "YOMCST.h"
    13   include "YOECUMF.h"
    1415
    1516! Entree

  • LMDZ6/branches/Amaury_dev/libf/phylmd/cvltr_scav.F90

    r5140 r5142  
    1515  USE infotrac_phy, ONLY: nbtr
    1616  USE lmdz_conema3
     17  USE lmdz_YOECUMF
    1718
    1819  IMPLICIT NONE
    … …  
    2425
    2526  include "YOMCST.h"
    26   include "YOECUMF.h"
    2727  include "chem.h"
    2828

  • LMDZ6/branches/Amaury_dev/libf/phylmd/cvltr_spl.F90

    r5140 r5142  
    1515  USE infotrac_phy, ONLY: nbtr
    1616  USE lmdz_conema3
     17  USE lmdz_YOECUMF
    1718
    1819  IMPLICIT NONE
    … …  
    2425
    2526  include "YOMCST.h"
    26   include "YOECUMF.h"
    2727  include "chem.h"
    2828

  • LMDZ6/branches/Amaury_dev/libf/phylmd/cvltrorig.F90

    r5116 r5142  
    55  USE dimphy
    66  USE infotrac_phy, ONLY: nbtr
     7  USE lmdz_YOECUMF
     8
    79  IMPLICIT NONE
    810!=====================================================================
    … …  
    1113!=====================================================================
    1214  include "YOMCST.h"
    13   include "YOECUMF.h"
    1415
    1516! Entree

  • LMDZ6/branches/Amaury_dev/libf/phylmd/dimphy.F90

    r5117 r5142  
    1 
    21! $Id$
    32
    4   MODULE dimphy
    5  
    6   INTEGER,SAVE :: klon
    7   INTEGER,SAVE :: kdlon
    8   INTEGER,SAVE :: kfdia
    9   INTEGER,SAVE :: kidia
    10   INTEGER,SAVE :: klev
    11   INTEGER,SAVE :: klevp1
    12   INTEGER,SAVE :: klevm1
    13   INTEGER,SAVE :: kflev
     3MODULE dimphy
    144
    15 !$OMP THREADPRIVATE(klon,kfdia,kidia,kdlon)
    16   REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: zmasq
    17 !$OMP THREADPRIVATE(zmasq)   
     5  INTEGER, SAVE :: klon
     6  INTEGER, SAVE :: kdlon
     7  INTEGER, SAVE :: kfdia
     8  INTEGER, SAVE :: kidia
     9  INTEGER, SAVE :: klev
     10  INTEGER, SAVE :: klevp1
     11  INTEGER, SAVE :: klevm1
     12  INTEGER, SAVE :: kflev
     13
     14  !$OMP THREADPRIVATE(klon,kfdia,kidia,kdlon)
     15  REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: zmasq
     16  !$OMP THREADPRIVATE(zmasq)
    1817
    1918CONTAINS
    20  
    21   SUBROUTINE Init_dimphy(klon0,klev0)
    22   IMPLICIT NONE
    23  
     19
     20  SUBROUTINE Init_dimphy(klon0, klev0)
     21    IMPLICIT NONE
     22
    2423    INTEGER, INTENT(IN) :: klon0
    2524    INTEGER, INTENT(IN) :: klev0
    26    
    27     klon=klon0
    28     kdlon=klon
    29     kidia=1
    30     kfdia=klon
    31 !$OMP MASTER
    32     klev=klev0
    33     klevp1=klev+1
    34     klevm1=klev-1
    35     kflev=klev
    36 !$OMP END MASTER   
    37     ALLOCATE(zmasq(klon))   
    38     zmasq=0.
    39    
     25
     26    klon = klon0
     27    kdlon = klon
     28    kidia = 1
     29    kfdia = klon
     30    !$OMP MASTER
     31    klev = klev0
     32    klevp1 = klev + 1
     33    klevm1 = klev - 1
     34    kflev = klev
     35    !$OMP END MASTER
     36    ALLOCATE(zmasq(klon))
     37    zmasq = 0.
     38
    4039  END SUBROUTINE Init_dimphy
    4140
    42   SUBROUTINE Init_dimphy1D(klon0,klev0)
    43 ! 1D special version of dimphy without ALLOCATE(zmasq)
    44 ! which will be allocated in iniphysiq
    45   IMPLICIT NONE
    46  
     41  SUBROUTINE Init_dimphy1D(klon0, klev0)
     42    ! 1D special version of dimphy without ALLOCATE(zmasq)
     43    ! which will be allocated in iniphysiq
     44    IMPLICIT NONE
     45
    4746    INTEGER, INTENT(IN) :: klon0
    4847    INTEGER, INTENT(IN) :: klev0
    49    
    50     klon=klon0
    51     kdlon=klon
    52     kidia=1
    53     kfdia=klon
    54     klev=klev0
    55     klevp1=klev+1
    56     klevm1=klev-1
    57     kflev=klev
    58    
     48
     49    klon = klon0
     50    kdlon = klon
     51    kidia = 1
     52    kfdia = klon
     53    klev = klev0
     54    klevp1 = klev + 1
     55    klevm1 = klev - 1
     56    kflev = klev
     57
    5958  END SUBROUTINE Init_dimphy1D
    6059
    61  
     60
    6261END MODULE dimphy

  • LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_1dutils.f90

    r5139 r5142  
    6565    USE lmdz_print_control, ONLY: lunout
    6666    USE lmdz_flux_arp, ONLY: fsens, flat, betaevap, ust, tg, ok_flux_surf, ok_prescr_ust, ok_prescr_beta, ok_forc_tsurf
    67 
     67    USE lmdz_fcs_gcssold, ONLY: imp_fcg_gcssold, ts_fcg_gcssold, Tp_fcg_gcssold, Tp_ini_gcssold, xTurb_fcg_gcssold
     68    USE lmdz_tsoilnudge, ONLY: nudge_tsoil, isoil_nudge, Tsoil_nudge, tau_soil_nudge
    6869    !-----------------------------------------------------------------------
    6970    !     Auteurs :   A. Lahellec  .
    … …  
    7374
    7475    include "compar1d.h"
    75     include "tsoilnudge.h"
    76     include "fcg_gcssold.h"
    7776    include "fcg_racmo.h"
    7877

  • LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_old_lmdz1d.F90

    r5139 r5142  
    5454    USE lmdz_flux_arp, ONLY: fsens, flat, betaevap, ust, tg, ok_flux_surf, ok_prescr_ust, ok_prescr_beta, ok_forc_tsurf
    5555    USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree
     56    USE lmdz_fcs_gcssold, ONLY: imp_fcg_gcssold, ts_fcg_gcssold, Tp_fcg_gcssold, Tp_ini_gcssold, xTurb_fcg_gcssold
     57    USE lmdz_tsoilnudge, ONLY: nudge_tsoil, isoil_nudge, Tsoil_nudge, tau_soil_nudge
    5658
    5759    INCLUDE "dimensions.h"
    … …  
    6062    INCLUDE "compar1d.h"
    6163    INCLUDE "date_cas.h"
    62     INCLUDE "tsoilnudge.h"
    63     INCLUDE "fcg_gcssold.h"
    6464
    6565    !=====================================================================

  • LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_scm.F90

    r5139 r5142  
    4747    USE lmdz_flux_arp, ONLY: fsens, flat, betaevap, ust, tg, ok_flux_surf, ok_prescr_ust, ok_prescr_beta, ok_forc_tsurf
    4848    USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree
     49    USE lmdz_fcs_gcssold, ONLY: imp_fcg_gcssold, ts_fcg_gcssold, Tp_fcg_gcssold, Tp_ini_gcssold, xTurb_fcg_gcssold
     50    USE lmdz_tsoilnudge, ONLY: nudge_tsoil, isoil_nudge, Tsoil_nudge, tau_soil_nudge
    4951
    5052    INCLUDE "dimensions.h"
    … …  
    5355    INCLUDE "compar1d.h"
    5456    INCLUDE "date_cas.h"
    55     INCLUDE "tsoilnudge.h"
    56     INCLUDE "fcg_gcssold.h"
    5757
    5858    !=====================================================================

  • LMDZ6/branches/Amaury_dev/libf/phylmd/flxtr.F90

    r5105 r5142  
    55    paprs, kcbot, kctop, kdtop, x, dx)
    66  USE dimphy
     7  USE lmdz_YOECUMF
     8
    79  IMPLICIT NONE
    810  ! =====================================================================
    … …  
    2628
    2729  include "YOMCST.h"
    28   include "YOECUMF.h"
    2930
    3031  REAL pdtime

  • LMDZ6/branches/Amaury_dev/libf/phylmd/freinage.F90

    r5139 r5142  
    99    USE lmdz_clesphys
    1010    USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree
     11    USE lmdz_dimpft, ONLY: nvm_lmdz
    1112!    USE control, ONLY: nvm
    1213!    USE indice_sol_mod, ONLY: nvm_orch
    … …  
    1718    include "YOMCST.h"
    1819    include "YOEGWD.h"
    19 !FC
    20     include "dimpft.h"
    2120
    2221    ! 0. DECLARATIONS:

  • LMDZ6/branches/Amaury_dev/libf/phylmd/ini_COSP.F90

    r5117 r5142  
    11!  A.I avril 2023
    22
    3   SUBROUTINE ini_COSP(ref_liq_cosp0,ref_ice_cosp0,pctsrf_cosp0,zu10m_cosp0,zv10m_cosp0, &
    4                       zxtsol_cosp0,zx_rh_cosp0,cldfra_cosp0,rnebcon_cosp0,flwc_cosp0, &
    5                       fiwc_cosp0,prfl_cosp0,psfl_cosp0,pmflxr_cosp0,pmflxs_cosp0, &
    6                       mr_ozone_cosp0,cldtau_cosp0,cldemi_cosp0,JrNt_cosp0)
     3SUBROUTINE ini_COSP(ref_liq_cosp0, ref_ice_cosp0, pctsrf_cosp0, zu10m_cosp0, zv10m_cosp0, &
     4        zxtsol_cosp0, zx_rh_cosp0, cldfra_cosp0, rnebcon_cosp0, flwc_cosp0, &
     5        fiwc_cosp0, prfl_cosp0, psfl_cosp0, pmflxr_cosp0, pmflxs_cosp0, &
     6        mr_ozone_cosp0, cldtau_cosp0, cldemi_cosp0, JrNt_cosp0)
    77
    8 ! Routine pour initialiser les champs input pour Cosp au  1er appel de celui-ci
    9 !         Ce 1er appel sert uniquement a definir les axes verticaux pour les
    10 !         sortie Cosp
     8  ! Routine pour initialiser les champs input pour Cosp au  1er appel de celui-ci
     9  !         Ce 1er appel sert uniquement a definir les axes verticaux pour les
     10  !         sortie Cosp
    1111
    12       USE dimphy
    13       include "ini_COSP.h"
     12  USE dimphy
     13  include "ini_COSP.h"
    1414
    15       ! Initialisations pour le 1er passage a Cosp
    16         ref_liq_cosp0=1.
    17         ref_ice_cosp0=1.
    18         pctsrf_cosp0=0.5
    19         zu10m_cosp0=1.
    20         zv10m_cosp0=1.
    21         zxtsol_cosp0=288.
    22         zx_rh_cosp0=1.
    23         cldfra_cosp0=1.
    24         rnebcon_cosp0=0.
    25         flwc_cosp0=0.
    26         fiwc_cosp0=0.
    27         prfl_cosp0(:,1:klev)=0.
    28         psfl_cosp0(:,1:klev)=0.
    29         pmflxr_cosp0(:,1:klev)=0.
    30         pmflxs_cosp0(:,1:klev)=0.
    31         mr_ozone_cosp0=0.
    32         cldtau_cosp0=0.
    33         cldemi_cosp0=0.
    34         JrNt_cosp0=0.
     15  ! Initialisations pour le 1er passage a Cosp
     16  ref_liq_cosp0 = 1.
     17  ref_ice_cosp0 = 1.
     18  pctsrf_cosp0 = 0.5
     19  zu10m_cosp0 = 1.
     20  zv10m_cosp0 = 1.
     21  zxtsol_cosp0 = 288.
     22  zx_rh_cosp0 = 1.
     23  cldfra_cosp0 = 1.
     24  rnebcon_cosp0 = 0.
     25  flwc_cosp0 = 0.
     26  fiwc_cosp0 = 0.
     27  prfl_cosp0(:, 1:klev) = 0.
     28  psfl_cosp0(:, 1:klev) = 0.
     29  pmflxr_cosp0(:, 1:klev) = 0.
     30  pmflxs_cosp0(:, 1:klev) = 0.
     31  mr_ozone_cosp0 = 0.
     32  cldtau_cosp0 = 0.
     33  cldemi_cosp0 = 0.
     34  JrNt_cosp0 = 0.
    3535
    36      END SUBROUTINE  ini_COSP
     36END SUBROUTINE  ini_COSP

  • LMDZ6/branches/Amaury_dev/libf/phylmd/iniorbit.F90

    r5105 r5142  
    11SUBROUTINE iniorbit(paphelie, pperiheli, pyear_day, pperi_day, pobliq)
     2  USE lmdz_planete, ONLY: aphelie, periheli, year_day, peri_day, obliquit, timeperi, e_elips, p_elips, unitastr
     3
    24  IMPLICIT NONE
    35
    … …  
    1820  ! ----------
    1921  ! - Doit etre appele avant d'utiliser orbite.
    20   ! - initialise une partie du common planete.h
     22  ! - initialise une partie du module lmdz_planete.f90
    2123
    2224  ! Arguments:
    … …  
    3335  ! Declarations:
    3436  ! -------------
    35 
    36   include "planete.h"
    3737  include "YOMCST.h"
    3838
    … …  
    5050  ! -----------------------------------------------------------------------
    5151
    52   pi = 2.*asin(1.)
     52  pi = 2. * asin(1.)
    5353
    5454  aphelie = paphelie
    … …  
    6464  PRINT *, 'Date perihelie : ', peri_day
    6565  unitastr = 149.597870
    66   e_elips = (aphelie-periheli)/(periheli+aphelie)
    67   p_elips = 0.5*(periheli+aphelie)*(1-e_elips*e_elips)/unitastr
     66  e_elips = (aphelie - periheli) / (periheli + aphelie)
     67  p_elips = 0.5 * (periheli + aphelie) * (1 - e_elips * e_elips) / unitastr
    6868
    6969  PRINT *, 'e_elips', e_elips
    … …  
    7676  ! calcul de l'zanomalie moyenne
    7777
    78   zz = (year_day-pperi_day)/year_day
    79   zanom = 2.*pi*(zz-nint(zz))
     78  zz = (year_day - pperi_day) / year_day
     79  zanom = 2. * pi * (zz - nint(zz))
    8080  zxref = abs(zanom)
    8181  PRINT *, 'zanom  ', zanom
    … …  
    8484  ! methode de Newton
    8585
    86   zx0 = zxref + r_ecc*sin(zxref)
     86  zx0 = zxref + r_ecc * sin(zxref)
    8787  DO iter = 1, 100
    88     zdx = -(zx0-r_ecc*sin(zx0)-zxref)/(1.-r_ecc*cos(zx0))
     88    zdx = -(zx0 - r_ecc * sin(zx0) - zxref) / (1. - r_ecc * cos(zx0))
    8989    IF (abs(zdx)<=(1.E-12)) GO TO 120
    9090    zx0 = zx0 + zdx
    9191  END DO
    92 120 CONTINUE
     92  120 CONTINUE
    9393  zx0 = zx0 + zdx
    9494  IF (zanom<0.) zx0 = -zx0
    … …  
    9797  ! zteta est la longitude solaire
    9898
    99   timeperi = 2.*atan(sqrt((1.+r_ecc)/(1.-r_ecc))*tan(zx0/2.))
     99  timeperi = 2. * atan(sqrt((1. + r_ecc) / (1. - r_ecc)) * tan(zx0 / 2.))
    100100  PRINT *, 'longitude solaire du perihelie timeperi = ', timeperi
    101101
    102 
    103102END SUBROUTINE iniorbit

  • LMDZ6/branches/Amaury_dev/libf/phylmd/init_be.F90

    r5117 r5142  
    77  USE indice_sol_mod
    88  USE lmdz_geometry, ONLY: longitude, latitude
     9  USE lmdz_YOECUMF
    910   
    1011  IMPLICIT NONE
    … …  
    2021
    2122  INCLUDE "YOMCST.h"
    22   INCLUDE "YOECUMF.h"
    2323
    2424! Input Arguments

  • LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_YOECUMF.f90

    r5141 r5142  
     1MODULE lmdz_YOECUMF
     2  !     ----------------------------------------------------------------
     3  !*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
     4  !     ----------------------------------------------------------------
    15
    2 ! $Id$
     6  IMPLICIT NONE; PRIVATE
     7  PUBLIC ENTRPEN, ENTRSCV, ENTRMID, ENTRDD, CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, &
     8          CPRCON, LMFPEN, LMFSCV, LMFMID, LMFDD, LMFDUDV
    39
    4 !  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
    5 !                 veillez n'utiliser que des ! pour les commentaires
    6 !                 et bien positionner les & des lignes de continuation
    7 !                 (les placer en colonne 6 et en colonne 73)
     10  LOGICAL          LMFPEN, LMFSCV, LMFMID, LMFDD, LMFDUDV
     11  REAL ENTRPEN, ENTRSCV, ENTRMID, ENTRDD
     12  REAL CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, CPRCON
     13  !$OMP THREADPRIVATE(ENTRPEN, ENTRSCV, ENTRMID, ENTRDD, CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, &
     14  !$OMP      CPRCON, LMFPEN, LMFSCV, LMFMID, LMFDD, LMFDUDV)
    815
    9 !     ----------------------------------------------------------------
    10 !*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
    11 !     ----------------------------------------------------------------
     16  !*if (DOC,declared) <> 'UNKNOWN'
     17  !*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
    1218
    13       COMMON /YOECUMF/                                                  &
    14                        ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,          &
    15                        CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON,            &
    16                        LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV
     19  !     M.TIEDTKE       E. C. M. W. F.      18/1/89
    1720
     21  !     NAME      TYPE      PURPOSE
     22  !     ----      ----      -------
    1823
    19       LOGICAL          LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV
    20       REAL ENTRPEN, ENTRSCV, ENTRMID, ENTRDD
    21       REAL CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, CPRCON
    22 !$OMP THREADPRIVATE(/YOECUMF/)
    23 
    24 !*if (DOC,declared) <> 'UNKNOWN'
    25 !*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
    26 
    27 !     M.TIEDTKE       E. C. M. W. F.      18/1/89
    28 
    29 !     NAME      TYPE      PURPOSE
    30 !     ----      ----      -------
    31 
    32 !     LMFPEN    LOGICAL  TRUE IF PENETRATIVE CONVECTION IS SWITCHED ON
    33 !     LMFSCV    LOGICAL  TRUE IF SHALLOW     CONVECTION IS SWITCHED ON
    34 !     LMFMID    LOGICAL  TRUE IF MIDLEVEL    CONVECTION IS SWITCHED ON
    35 !     LMFDD     LOGICAL  TRUE IF CUMULUS DOWNDRAFT      IS SWITCHED ON
    36 !     LMFDUDV   LOGICAL  TRUE IF CUMULUS FRICTION       IS SWITCHED ON
    37 !     ENTRPEN   REAL     ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
    38 !     ENTRSCV   REAL     ENTRAINMENT RATE FOR SHALLOW CONVECTION
    39 !     ENTRMID   REAL     ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
    40 !     ENTRDD    REAL     ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
    41 !     CMFCTOP   REAL     RELAT. CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANC
    42 !     CMFCMAX   REAL     MAXIMUM MASSFLUX VALUE ALLOWED FOR
    43 !     CMFCMIN   REAL     MINIMUM MASSFLUX VALUE (FOR SAFETY)
    44 !     CMFDEPS   REAL     FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
    45 !     RHCDD     REAL     RELATIVE SATURATION IN DOWNDRAFTS
    46 !     CPRCON    REAL     COEFFICIENTS FOR DETERMINING CONVERSION
    47 !                        FROM CLOUD WATER TO RAIN
    48 !*ifend
    49 !     ----------------------------------------------------------------
     24  !     LMFPEN    LOGICAL  TRUE IF PENETRATIVE CONVECTION IS SWITCHED ON
     25  !     LMFSCV    LOGICAL  TRUE IF SHALLOW     CONVECTION IS SWITCHED ON
     26  !     LMFMID    LOGICAL  TRUE IF MIDLEVEL    CONVECTION IS SWITCHED ON
     27  !     LMFDD     LOGICAL  TRUE IF CUMULUS DOWNDRAFT      IS SWITCHED ON
     28  !     LMFDUDV   LOGICAL  TRUE IF CUMULUS FRICTION       IS SWITCHED ON
     29  !     ENTRPEN   REAL     ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
     30  !     ENTRSCV   REAL     ENTRAINMENT RATE FOR SHALLOW CONVECTION
     31  !     ENTRMID   REAL     ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
     32  !     ENTRDD    REAL     ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
     33  !     CMFCTOP   REAL     RELAT. CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANC
     34  !     CMFCMAX   REAL     MAXIMUM MASSFLUX VALUE ALLOWED FOR
     35  !     CMFCMIN   REAL     MINIMUM MASSFLUX VALUE (FOR SAFETY)
     36  !     CMFDEPS   REAL     FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
     37  !     RHCDD     REAL     RELATIVE SATURATION IN DOWNDRAFTS
     38  !     CPRCON    REAL     COEFFICIENTS FOR DETERMINING CONVERSION
     39  !                        FROM CLOUD WATER TO RAIN
     40  !*ifend
     41  !     ----------------------------------------------------------------
     42END MODULE lmdz_YOECUMF

  • LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_cv.f90

    r5141 r5142  
    11! $Id$
    22
    3 SUBROUTINE cv_param(nd)
    4   IMPLICIT NONE
    5 
    6   ! ------------------------------------------------------------
    7   ! Set parameters for convectL
    8   ! (includes microphysical parameters and parameters that
    9   ! control the rate of approach to quasi-equilibrium)
    10   ! ------------------------------------------------------------
    11 
    12   ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
    13   ! ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
    14   ! ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
    15   ! ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
    16   ! ***               BETWEEN 0 C AND TLCRIT)                        ***
    17   ! ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
    18   ! ***                       FORMULATION                            ***
    19   ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
    20   ! ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
    21   ! ***                        OF CLOUD                              ***
    22   ! ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
    23   ! ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
    24   ! ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
    25   ! ***                          OF RAIN                             ***
    26   ! ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
    27   ! ***                          OF SNOW                             ***
    28   ! ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
    29   ! ***                         TRANSPORT                            ***
    30   ! ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
    31   ! ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
    32   ! ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
    33   ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
    34   ! ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
    35   ! ***                   (DAMP MUST BE LESS THAN 1)                 ***
    36 
    37   include "cvparam.h"
    38   INTEGER nd
    39   CHARACTER (LEN = 20) :: modname = 'cv_routines'
    40   CHARACTER (LEN = 80) :: abort_message
    41 
    42   ! noff: integer limit for convection (nd-noff)
    43   ! minorig: First level of convection
    44 
    45   noff = 2
    46   minorig = 2
    47 
    48   nl = nd - noff
    49   nlp = nl + 1
    50   nlm = nl - 1
    51 
    52   elcrit = 0.0011
    53   tlcrit = -55.0
    54   entp = 1.5
    55   sigs = 0.12
    56   sigd = 0.05
    57   omtrain = 50.0
    58   omtsnow = 5.5
    59   coeffr = 1.0
    60   coeffs = 0.8
    61   dtmax = 0.9
    62 
    63   cu = 0.70
    64 
    65   betad = 10.0
    66 
    67   damp = 0.1
    68   alpha = 0.2
    69 
    70   delta = 0.01 ! cld
    71 
    72 END SUBROUTINE cv_param
    73 
    74 SUBROUTINE cv_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm)
    75   USE lmdz_cvthermo
    76 
    77   IMPLICIT NONE
    78 
    79   ! =====================================================================
    80   ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
    81   ! =====================================================================
    82 
    83   ! inputs:
    84   INTEGER len, nd, ndp1
    85   REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
    86 
    87   ! outputs:
    88   REAL lv(len, nd), cpn(len, nd), tv(len, nd)
    89   REAL gz(len, nd), h(len, nd), hm(len, nd)
    90 
    91   ! local variables:
    92   INTEGER k, i
    93   REAL cpx(len, nd)
    94 
    95   include "cvparam.h"
    96 
    97   DO k = 1, nlp
     3MODULE lmdz_cv
     4  !------------------------------------------------------------
     5  ! Parameters for convectL:
     6  ! (includes - microphysical parameters,
     7  !                     - parameters that control the rate of approach
     8  !               to quasi-equilibrium)
     9  !                     - noff & minorig (previously in input of convect1)
     10  !------------------------------------------------------------
     11
     12  IMPLICIT NONE; PRIVATE
     13  PUBLIC elcrit, tlcrit, entp, sigs, sigd, omtrain, omtsnow, coeffr, coeffs &
     14          , dtmax, cu, betad, alpha, damp, delta, noff, minorig, nl, nlp, nlm, &
     15          cv_param, cv_prelim, cv_feed, cv_undilute1, cv_trigger, cv_compress, &
     16          cv_undilute2, cv_closure, cv_mixing, cv_unsat, cv_yield, cv_uncompress
     17
     18  INTEGER noff, minorig, nl, nlp, nlm
     19  REAL elcrit, tlcrit
     20  REAL entp
     21  REAL sigs, sigd
     22  REAL omtrain, omtsnow, coeffr, coeffs
     23  REAL dtmax
     24  REAL cu
     25  REAL betad
     26  REAL alpha, damp
     27  REAL delta
     28
     29  !$OMP THREADPRIVATE(elcrit, tlcrit, entp, sigs, sigd, omtrain, omtsnow, coeffr, coeffs &
     30  !$OMP      , dtmax, cu, betad, alpha, damp, delta, noff, minorig, nl, nlp, nlm)
     31
     32CONTAINS
     33
     34  SUBROUTINE cv_param(nd)
     35    IMPLICIT NONE
     36
     37    ! ------------------------------------------------------------
     38    ! Set parameters for convectL
     39    ! (includes microphysical parameters and parameters that
     40    ! control the rate of approach to quasi-equilibrium)
     41    ! ------------------------------------------------------------
     42
     43    ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
     44    ! ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
     45    ! ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
     46    ! ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
     47    ! ***               BETWEEN 0 C AND TLCRIT)                        ***
     48    ! ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
     49    ! ***                       FORMULATION                            ***
     50    ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
     51    ! ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
     52    ! ***                        OF CLOUD                              ***
     53    ! ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
     54    ! ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
     55    ! ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
     56    ! ***                          OF RAIN                             ***
     57    ! ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
     58    ! ***                          OF SNOW                             ***
     59    ! ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
     60    ! ***                         TRANSPORT                            ***
     61    ! ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
     62    ! ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
     63    ! ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
     64    ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
     65    ! ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
     66    ! ***                   (DAMP MUST BE LESS THAN 1)                 ***
     67
     68        INTEGER nd
     69    CHARACTER (LEN = 20) :: modname = 'cv_routines'
     70    CHARACTER (LEN = 80) :: abort_message
     71
     72    ! noff: integer limit for convection (nd-noff)
     73    ! minorig: First level of convection
     74
     75    noff = 2
     76    minorig = 2
     77
     78    nl = nd - noff
     79    nlp = nl + 1
     80    nlm = nl - 1
     81
     82    elcrit = 0.0011
     83    tlcrit = -55.0
     84    entp = 1.5
     85    sigs = 0.12
     86    sigd = 0.05
     87    omtrain = 50.0
     88    omtsnow = 5.5
     89    coeffr = 1.0
     90    coeffs = 0.8
     91    dtmax = 0.9
     92
     93    cu = 0.70
     94
     95    betad = 10.0
     96
     97    damp = 0.1
     98    alpha = 0.2
     99
     100    delta = 0.01 ! cld
     101
     102  END SUBROUTINE cv_param
     103
     104  SUBROUTINE cv_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm)
     105    USE lmdz_cvthermo
     106
     107    IMPLICIT NONE
     108
     109    ! =====================================================================
     110    ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
     111    ! =====================================================================
     112
     113    ! inputs:
     114    INTEGER len, nd, ndp1
     115    REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
     116
     117    ! outputs:
     118    REAL lv(len, nd), cpn(len, nd), tv(len, nd)
     119    REAL gz(len, nd), h(len, nd), hm(len, nd)
     120
     121    ! local variables:
     122    INTEGER k, i
     123    REAL cpx(len, nd)
     124
     125
     126    DO k = 1, nlp
     127      DO i = 1, len
     128        lv(i, k) = lv0 - clmcpv * (t(i, k) - t0)
     129        cpn(i, k) = cpd * (1.0 - q(i, k)) + cpv * q(i, k)
     130        cpx(i, k) = cpd * (1.0 - q(i, k)) + cl * q(i, k)
     131        tv(i, k) = t(i, k) * (1.0 + q(i, k) * epsim1)
     132      END DO
     133    END DO
     134
     135    ! gz = phi at the full levels (same as p).
     136
    98137    DO i = 1, len
    99       lv(i, k) = lv0 - clmcpv * (t(i, k) - t0)
    100       cpn(i, k) = cpd * (1.0 - q(i, k)) + cpv * q(i, k)
    101       cpx(i, k) = cpd * (1.0 - q(i, k)) + cl * q(i, k)
    102       tv(i, k) = t(i, k) * (1.0 + q(i, k) * epsim1)
    103     END DO
    104   END DO
    105 
    106   ! gz = phi at the full levels (same as p).
    107 
    108   DO i = 1, len
    109     gz(i, 1) = 0.0
    110   END DO
    111   DO k = 2, nlp
     138      gz(i, 1) = 0.0
     139    END DO
     140    DO k = 2, nlp
     141      DO i = 1, len
     142        gz(i, k) = gz(i, k - 1) + hrd * (tv(i, k - 1) + tv(i, k)) * (p(i, k - 1) - p(i, k)) / ph(i, &
     143                k)
     144      END DO
     145    END DO
     146
     147    ! h  = phi + cpT (dry static energy).
     148    ! hm = phi + cp(T-Tbase)+Lq
     149
     150    DO k = 1, nlp
     151      DO i = 1, len
     152        h(i, k) = gz(i, k) + cpn(i, k) * t(i, k)
     153        hm(i, k) = gz(i, k) + cpx(i, k) * (t(i, k) - t(i, 1)) + lv(i, k) * q(i, k)
     154      END DO
     155    END DO
     156
     157  END SUBROUTINE cv_prelim
     158
     159  SUBROUTINE cv_feed(len, nd, t, q, qs, p, hm, gz, nk, icb, icbmax, iflag, tnk, &
     160          qnk, gznk, plcl)
     161    IMPLICIT NONE
     162
     163    ! ================================================================
     164    ! Purpose: CONVECTIVE FEED
     165    ! ================================================================
     166
     167
     168    ! inputs:
     169    INTEGER len, nd
     170    REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd)
     171    REAL hm(len, nd), gz(len, nd)
     172
     173    ! outputs:
     174    INTEGER iflag(len), nk(len), icb(len), icbmax
     175    REAL tnk(len), qnk(len), gznk(len), plcl(len)
     176
     177    ! local variables:
     178    INTEGER i, k
     179    INTEGER ihmin(len)
     180    REAL work(len)
     181    REAL pnk(len), qsnk(len), rh(len), chi(len)
     182
     183    ! -------------------------------------------------------------------
     184    ! --- Find level of minimum moist static energy
     185    ! --- If level of minimum moist static energy coincides with
     186    ! --- or is lower than minimum allowable parcel origin level,
     187    ! --- set iflag to 6.
     188    ! -------------------------------------------------------------------
     189
    112190    DO i = 1, len
    113       gz(i, k) = gz(i, k - 1) + hrd * (tv(i, k - 1) + tv(i, k)) * (p(i, k - 1) - p(i, k)) / ph(i, &
    114               k)
    115     END DO
    116   END DO
    117 
    118   ! h  = phi + cpT (dry static energy).
    119   ! hm = phi + cp(T-Tbase)+Lq
    120 
    121   DO k = 1, nlp
     191      work(i) = 1.0E12
     192      ihmin(i) = nl
     193    END DO
     194    DO k = 2, nlp
     195      DO i = 1, len
     196        IF ((hm(i, k)<work(i)) .AND. (hm(i, k)<hm(i, k - 1))) THEN
     197          work(i) = hm(i, k)
     198          ihmin(i) = k
     199        END IF
     200      END DO
     201    END DO
    122202    DO i = 1, len
    123       h(i, k) = gz(i, k) + cpn(i, k) * t(i, k)
    124       hm(i, k) = gz(i, k) + cpx(i, k) * (t(i, k) - t(i, 1)) + lv(i, k) * q(i, k)
    125     END DO
    126   END DO
    127 
    128 END SUBROUTINE cv_prelim
    129 
    130 SUBROUTINE cv_feed(len, nd, t, q, qs, p, hm, gz, nk, icb, icbmax, iflag, tnk, &
    131         qnk, gznk, plcl)
    132   IMPLICIT NONE
    133 
    134   ! ================================================================
    135   ! Purpose: CONVECTIVE FEED
    136   ! ================================================================
    137 
    138   include "cvparam.h"
    139 
    140   ! inputs:
    141   INTEGER len, nd
    142   REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd)
    143   REAL hm(len, nd), gz(len, nd)
    144 
    145   ! outputs:
    146   INTEGER iflag(len), nk(len), icb(len), icbmax
    147   REAL tnk(len), qnk(len), gznk(len), plcl(len)
    148 
    149   ! local variables:
    150   INTEGER i, k
    151   INTEGER ihmin(len)
    152   REAL work(len)
    153   REAL pnk(len), qsnk(len), rh(len), chi(len)
    154 
    155   ! -------------------------------------------------------------------
    156   ! --- Find level of minimum moist static energy
    157   ! --- If level of minimum moist static energy coincides with
    158   ! --- or is lower than minimum allowable parcel origin level,
    159   ! --- set iflag to 6.
    160   ! -------------------------------------------------------------------
    161 
    162   DO i = 1, len
    163     work(i) = 1.0E12
    164     ihmin(i) = nl
    165   END DO
    166   DO k = 2, nlp
     203      ihmin(i) = min(ihmin(i), nlm)
     204      IF (ihmin(i)<=minorig) THEN
     205        iflag(i) = 6
     206      END IF
     207    END DO
     208
     209    ! -------------------------------------------------------------------
     210    ! --- Find that model level below the level of minimum moist static
     211    ! --- energy that has the maximum value of moist static energy
     212    ! -------------------------------------------------------------------
     213
    167214    DO i = 1, len
    168       IF ((hm(i, k)<work(i)) .AND. (hm(i, k)<hm(i, k - 1))) THEN
    169         work(i) = hm(i, k)
    170         ihmin(i) = k
     215      work(i) = hm(i, minorig)
     216      nk(i) = minorig
     217    END DO
     218    DO k = minorig + 1, nl
     219      DO i = 1, len
     220        IF ((hm(i, k)>work(i)) .AND. (k<=ihmin(i))) THEN
     221          work(i) = hm(i, k)
     222          nk(i) = k
     223        END IF
     224      END DO
     225    END DO
     226    ! -------------------------------------------------------------------
     227    ! --- Check whether parcel level temperature and specific humidity
     228    ! --- are reasonable
     229    ! -------------------------------------------------------------------
     230    DO i = 1, len
     231      IF (((t(i, nk(i))<250.0) .OR. (q(i, nk(i))<=0.0) .OR. (p(i, ihmin(i))< &
     232              400.0)) .AND. (iflag(i)==0)) iflag(i) = 7
     233    END DO
     234    ! -------------------------------------------------------------------
     235    ! --- Calculate lifted condensation level of air at parcel origin level
     236    ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
     237    ! -------------------------------------------------------------------
     238    DO i = 1, len
     239      tnk(i) = t(i, nk(i))
     240      qnk(i) = q(i, nk(i))
     241      gznk(i) = gz(i, nk(i))
     242      pnk(i) = p(i, nk(i))
     243      qsnk(i) = qs(i, nk(i))
     244
     245      rh(i) = qnk(i) / qsnk(i)
     246      rh(i) = min(1.0, rh(i))
     247      chi(i) = tnk(i) / (1669.0 - 122.0 * rh(i) - tnk(i))
     248      plcl(i) = pnk(i) * (rh(i)**chi(i))
     249      IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag(i &
     250              ) = 8
     251    END DO
     252    ! -------------------------------------------------------------------
     253    ! --- Calculate first level above lcl (=icb)
     254    ! -------------------------------------------------------------------
     255    DO i = 1, len
     256      icb(i) = nlm
     257    END DO
     258
     259    DO k = minorig, nl
     260      DO i = 1, len
     261        IF ((k>=(nk(i) + 1)) .AND. (p(i, k)<plcl(i))) icb(i) = min(icb(i), k)
     262      END DO
     263    END DO
     264
     265    DO i = 1, len
     266      IF ((icb(i)>=nlm) .AND. (iflag(i)==0)) iflag(i) = 9
     267    END DO
     268
     269    ! Compute icbmax.
     270
     271    icbmax = 2
     272    DO i = 1, len
     273      icbmax = max(icbmax, icb(i))
     274    END DO
     275
     276  END SUBROUTINE cv_feed
     277
     278  SUBROUTINE cv_undilute1(len, nd, t, q, qs, gz, p, nk, icb, icbmax, tp, tvp, &
     279          clw)
     280    USE lmdz_cvthermo
     281
     282    IMPLICIT NONE
     283
     284
     285    ! inputs:
     286    INTEGER len, nd
     287    INTEGER nk(len), icb(len), icbmax
     288    REAL t(len, nd), q(len, nd), qs(len, nd), gz(len, nd)
     289    REAL p(len, nd)
     290
     291    ! outputs:
     292    REAL tp(len, nd), tvp(len, nd), clw(len, nd)
     293
     294    ! local variables:
     295    INTEGER i, k
     296    REAL tg, qg, alv, s, ahg, tc, denom, es, rg
     297    REAL ah0(len), cpp(len)
     298    REAL tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
     299
     300    ! -------------------------------------------------------------------
     301    ! --- Calculates the lifted parcel virtual temperature at nk,
     302    ! --- the actual temperature, and the adiabatic
     303    ! --- liquid water content. The procedure is to solve the equation.
     304    ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
     305    ! -------------------------------------------------------------------
     306
     307    DO i = 1, len
     308      tnk(i) = t(i, nk(i))
     309      qnk(i) = q(i, nk(i))
     310      gznk(i) = gz(i, nk(i))
     311      ticb(i) = t(i, icb(i))
     312      gzicb(i) = gz(i, icb(i))
     313    END DO
     314
     315    ! ***  Calculate certain parcel quantities, including static energy   ***
     316
     317    DO i = 1, len
     318      ah0(i) = (cpd * (1. - qnk(i)) + cl * qnk(i)) * tnk(i) + qnk(i) * (lv0 - clmcpv * (tnk(i) - &
     319              273.15)) + gznk(i)
     320      cpp(i) = cpd * (1. - qnk(i)) + qnk(i) * cpv
     321    END DO
     322
     323    ! ***   Calculate lifted parcel quantities below cloud base   ***
     324
     325    DO k = minorig, icbmax - 1
     326      DO i = 1, len
     327        tp(i, k) = tnk(i) - (gz(i, k) - gznk(i)) / cpp(i)
     328        tvp(i, k) = tp(i, k) * (1. + qnk(i) * epsi)
     329      END DO
     330    END DO
     331
     332    ! ***  Find lifted parcel quantities above cloud base    ***
     333
     334    DO i = 1, len
     335      tg = ticb(i)
     336      qg = qs(i, icb(i))
     337      alv = lv0 - clmcpv * (ticb(i) - t0)
     338
     339      ! First iteration.
     340
     341      s = cpd + alv * alv * qg / (rrv * ticb(i) * ticb(i))
     342      s = 1. / s
     343      ahg = cpd * tg + (cl - cpd) * qnk(i) * ticb(i) + alv * qg + gzicb(i)
     344      tg = tg + s * (ah0(i) - ahg)
     345      tg = max(tg, 35.0)
     346      tc = tg - t0
     347      denom = 243.5 + tc
     348      IF (tc>=0.0) THEN
     349        es = 6.112 * exp(17.67 * tc / denom)
     350      ELSE
     351        es = exp(23.33086 - 6111.72784 / tg + 0.15215 * log(tg))
    171352      END IF
    172     END DO
    173   END DO
    174   DO i = 1, len
    175     ihmin(i) = min(ihmin(i), nlm)
    176     IF (ihmin(i)<=minorig) THEN
    177       iflag(i) = 6
     353      qg = eps * es / (p(i, icb(i)) - es * (1. - eps))
     354
     355      ! Second iteration.
     356
     357      s = cpd + alv * alv * qg / (rrv * ticb(i) * ticb(i))
     358      s = 1. / s
     359      ahg = cpd * tg + (cl - cpd) * qnk(i) * ticb(i) + alv * qg + gzicb(i)
     360      tg = tg + s * (ah0(i) - ahg)
     361      tg = max(tg, 35.0)
     362      tc = tg - t0
     363      denom = 243.5 + tc
     364      IF (tc>=0.0) THEN
     365        es = 6.112 * exp(17.67 * tc / denom)
     366      ELSE
     367        es = exp(23.33086 - 6111.72784 / tg + 0.15215 * log(tg))
     368      END IF
     369      qg = eps * es / (p(i, icb(i)) - es * (1. - eps))
     370
     371      alv = lv0 - clmcpv * (ticb(i) - 273.15)
     372      tp(i, icb(i)) = (ah0(i) - (cl - cpd) * qnk(i) * ticb(i) - gz(i, icb(i)) - alv * qg) / cpd
     373      clw(i, icb(i)) = qnk(i) - qg
     374      clw(i, icb(i)) = max(0.0, clw(i, icb(i)))
     375      rg = qg / (1. - qnk(i))
     376      tvp(i, icb(i)) = tp(i, icb(i)) * (1. + rg * epsi)
     377    END DO
     378
     379    DO k = minorig, icbmax
     380      DO i = 1, len
     381        tvp(i, k) = tvp(i, k) - tp(i, k) * qnk(i)
     382      END DO
     383    END DO
     384
     385  END SUBROUTINE cv_undilute1
     386
     387  SUBROUTINE cv_trigger(len, nd, icb, cbmf, tv, tvp, iflag)
     388    IMPLICIT NONE
     389
     390    ! -------------------------------------------------------------------
     391    ! --- Test for instability.
     392    ! --- If there was no convection at last time step and parcel
     393    ! --- is stable at icb, then set iflag to 4.
     394    ! -------------------------------------------------------------------
     395
     396
     397    ! inputs:
     398    INTEGER len, nd, icb(len)
     399    REAL cbmf(len), tv(len, nd), tvp(len, nd)
     400
     401    ! outputs:
     402    INTEGER iflag(len) ! also an input
     403
     404    ! local variables:
     405    INTEGER i
     406
     407    DO i = 1, len
     408      IF ((cbmf(i)==0.0) .AND. (iflag(i)==0) .AND. (tvp(i, &
     409              icb(i))<=(tv(i, icb(i)) - dtmax))) iflag(i) = 4
     410    END DO
     411
     412  END SUBROUTINE cv_trigger
     413
     414  SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, nk1, icb1, cbmf1, plcl1, &
     415          tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, tv1, &
     416          tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, q, qs, u, &
     417          v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, dph)
     418    USE lmdz_print_control, ONLY: lunout
     419    USE lmdz_abort_physic, ONLY: abort_physic
     420    IMPLICIT NONE
     421
     422
     423    ! inputs:
     424    INTEGER len, ncum, nd, nloc
     425    INTEGER iflag1(len), nk1(len), icb1(len)
     426    REAL cbmf1(len), plcl1(len), tnk1(len), qnk1(len), gznk1(len)
     427    REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
     428    REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
     429    REAL p1(len, nd), ph1(len, nd + 1), tv1(len, nd), tp1(len, nd)
     430    REAL tvp1(len, nd), clw1(len, nd)
     431
     432    ! outputs:
     433    INTEGER iflag(nloc), nk(nloc), icb(nloc)
     434    REAL cbmf(nloc), plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
     435    REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
     436    REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
     437    REAL p(nloc, nd), ph(nloc, nd + 1), tv(nloc, nd), tp(nloc, nd)
     438    REAL tvp(nloc, nd), clw(nloc, nd)
     439    REAL dph(nloc, nd)
     440
     441    ! local variables:
     442    INTEGER i, k, nn
     443    CHARACTER (LEN = 20) :: modname = 'cv_compress'
     444    CHARACTER (LEN = 80) :: abort_message
     445
     446    DO k = 1, nl + 1
     447      nn = 0
     448      DO i = 1, len
     449        IF (iflag1(i)==0) THEN
     450          nn = nn + 1
     451          t(nn, k) = t1(i, k)
     452          q(nn, k) = q1(i, k)
     453          qs(nn, k) = qs1(i, k)
     454          u(nn, k) = u1(i, k)
     455          v(nn, k) = v1(i, k)
     456          gz(nn, k) = gz1(i, k)
     457          h(nn, k) = h1(i, k)
     458          lv(nn, k) = lv1(i, k)
     459          cpn(nn, k) = cpn1(i, k)
     460          p(nn, k) = p1(i, k)
     461          ph(nn, k) = ph1(i, k)
     462          tv(nn, k) = tv1(i, k)
     463          tp(nn, k) = tp1(i, k)
     464          tvp(nn, k) = tvp1(i, k)
     465          clw(nn, k) = clw1(i, k)
     466        END IF
     467      END DO
     468    END DO
     469
     470    IF (nn/=ncum) THEN
     471      WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
     472      abort_message = ''
     473      CALL abort_physic(modname, abort_message, 1)
    178474    END IF
    179   END DO
    180 
    181   ! -------------------------------------------------------------------
    182   ! --- Find that model level below the level of minimum moist static
    183   ! --- energy that has the maximum value of moist static energy
    184   ! -------------------------------------------------------------------
    185 
    186   DO i = 1, len
    187     work(i) = hm(i, minorig)
    188     nk(i) = minorig
    189   END DO
    190   DO k = minorig + 1, nl
    191     DO i = 1, len
    192       IF ((hm(i, k)>work(i)) .AND. (k<=ihmin(i))) THEN
    193         work(i) = hm(i, k)
    194         nk(i) = k
    195       END IF
    196     END DO
    197   END DO
    198   ! -------------------------------------------------------------------
    199   ! --- Check whether parcel level temperature and specific humidity
    200   ! --- are reasonable
    201   ! -------------------------------------------------------------------
    202   DO i = 1, len
    203     IF (((t(i, nk(i))<250.0) .OR. (q(i, nk(i))<=0.0) .OR. (p(i, ihmin(i))< &
    204             400.0)) .AND. (iflag(i)==0)) iflag(i) = 7
    205   END DO
    206   ! -------------------------------------------------------------------
    207   ! --- Calculate lifted condensation level of air at parcel origin level
    208   ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
    209   ! -------------------------------------------------------------------
    210   DO i = 1, len
    211     tnk(i) = t(i, nk(i))
    212     qnk(i) = q(i, nk(i))
    213     gznk(i) = gz(i, nk(i))
    214     pnk(i) = p(i, nk(i))
    215     qsnk(i) = qs(i, nk(i))
    216 
    217     rh(i) = qnk(i) / qsnk(i)
    218     rh(i) = min(1.0, rh(i))
    219     chi(i) = tnk(i) / (1669.0 - 122.0 * rh(i) - tnk(i))
    220     plcl(i) = pnk(i) * (rh(i)**chi(i))
    221     IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag(i &
    222             ) = 8
    223   END DO
    224   ! -------------------------------------------------------------------
    225   ! --- Calculate first level above lcl (=icb)
    226   ! -------------------------------------------------------------------
    227   DO i = 1, len
    228     icb(i) = nlm
    229   END DO
    230 
    231   DO k = minorig, nl
    232     DO i = 1, len
    233       IF ((k>=(nk(i) + 1)) .AND. (p(i, k)<plcl(i))) icb(i) = min(icb(i), k)
    234     END DO
    235   END DO
    236 
    237   DO i = 1, len
    238     IF ((icb(i)>=nlm) .AND. (iflag(i)==0)) iflag(i) = 9
    239   END DO
    240 
    241   ! Compute icbmax.
    242 
    243   icbmax = 2
    244   DO i = 1, len
    245     icbmax = max(icbmax, icb(i))
    246   END DO
    247 
    248 END SUBROUTINE cv_feed
    249 
    250 SUBROUTINE cv_undilute1(len, nd, t, q, qs, gz, p, nk, icb, icbmax, tp, tvp, &
    251         clw)
    252   USE lmdz_cvthermo
    253 
    254   IMPLICIT NONE
    255 
    256   include "cvparam.h"
    257 
    258   ! inputs:
    259   INTEGER len, nd
    260   INTEGER nk(len), icb(len), icbmax
    261   REAL t(len, nd), q(len, nd), qs(len, nd), gz(len, nd)
    262   REAL p(len, nd)
    263 
    264   ! outputs:
    265   REAL tp(len, nd), tvp(len, nd), clw(len, nd)
    266 
    267   ! local variables:
    268   INTEGER i, k
    269   REAL tg, qg, alv, s, ahg, tc, denom, es, rg
    270   REAL ah0(len), cpp(len)
    271   REAL tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
    272 
    273   ! -------------------------------------------------------------------
    274   ! --- Calculates the lifted parcel virtual temperature at nk,
    275   ! --- the actual temperature, and the adiabatic
    276   ! --- liquid water content. The procedure is to solve the equation.
    277   ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
    278   ! -------------------------------------------------------------------
    279 
    280   DO i = 1, len
    281     tnk(i) = t(i, nk(i))
    282     qnk(i) = q(i, nk(i))
    283     gznk(i) = gz(i, nk(i))
    284     ticb(i) = t(i, icb(i))
    285     gzicb(i) = gz(i, icb(i))
    286   END DO
    287 
    288   ! ***  Calculate certain parcel quantities, including static energy   ***
    289 
    290   DO i = 1, len
    291     ah0(i) = (cpd * (1. - qnk(i)) + cl * qnk(i)) * tnk(i) + qnk(i) * (lv0 - clmcpv * (tnk(i) - &
    292             273.15)) + gznk(i)
    293     cpp(i) = cpd * (1. - qnk(i)) + qnk(i) * cpv
    294   END DO
    295 
    296   ! ***   Calculate lifted parcel quantities below cloud base   ***
    297 
    298   DO k = minorig, icbmax - 1
    299     DO i = 1, len
    300       tp(i, k) = tnk(i) - (gz(i, k) - gznk(i)) / cpp(i)
    301       tvp(i, k) = tp(i, k) * (1. + qnk(i) * epsi)
    302     END DO
    303   END DO
    304 
    305   ! ***  Find lifted parcel quantities above cloud base    ***
    306 
    307   DO i = 1, len
    308     tg = ticb(i)
    309     qg = qs(i, icb(i))
    310     alv = lv0 - clmcpv * (ticb(i) - t0)
    311 
    312     ! First iteration.
    313 
    314     s = cpd + alv * alv * qg / (rrv * ticb(i) * ticb(i))
    315     s = 1. / s
    316     ahg = cpd * tg + (cl - cpd) * qnk(i) * ticb(i) + alv * qg + gzicb(i)
    317     tg = tg + s * (ah0(i) - ahg)
    318     tg = max(tg, 35.0)
    319     tc = tg - t0
    320     denom = 243.5 + tc
    321     IF (tc>=0.0) THEN
    322       es = 6.112 * exp(17.67 * tc / denom)
    323     ELSE
    324       es = exp(23.33086 - 6111.72784 / tg + 0.15215 * log(tg))
    325     END IF
    326     qg = eps * es / (p(i, icb(i)) - es * (1. - eps))
    327 
    328     ! Second iteration.
    329 
    330     s = cpd + alv * alv * qg / (rrv * ticb(i) * ticb(i))
    331     s = 1. / s
    332     ahg = cpd * tg + (cl - cpd) * qnk(i) * ticb(i) + alv * qg + gzicb(i)
    333     tg = tg + s * (ah0(i) - ahg)
    334     tg = max(tg, 35.0)
    335     tc = tg - t0
    336     denom = 243.5 + tc
    337     IF (tc>=0.0) THEN
    338       es = 6.112 * exp(17.67 * tc / denom)
    339     ELSE
    340       es = exp(23.33086 - 6111.72784 / tg + 0.15215 * log(tg))
    341     END IF
    342     qg = eps * es / (p(i, icb(i)) - es * (1. - eps))
    343 
    344     alv = lv0 - clmcpv * (ticb(i) - 273.15)
    345     tp(i, icb(i)) = (ah0(i) - (cl - cpd) * qnk(i) * ticb(i) - gz(i, icb(i)) - alv * qg) / cpd
    346     clw(i, icb(i)) = qnk(i) - qg
    347     clw(i, icb(i)) = max(0.0, clw(i, icb(i)))
    348     rg = qg / (1. - qnk(i))
    349     tvp(i, icb(i)) = tp(i, icb(i)) * (1. + rg * epsi)
    350   END DO
    351 
    352   DO k = minorig, icbmax
    353     DO i = 1, len
    354       tvp(i, k) = tvp(i, k) - tp(i, k) * qnk(i)
    355     END DO
    356   END DO
    357 
    358 END SUBROUTINE cv_undilute1
    359 
    360 SUBROUTINE cv_trigger(len, nd, icb, cbmf, tv, tvp, iflag)
    361   IMPLICIT NONE
    362 
    363   ! -------------------------------------------------------------------
    364   ! --- Test for instability.
    365   ! --- If there was no convection at last time step and parcel
    366   ! --- is stable at icb, then set iflag to 4.
    367   ! -------------------------------------------------------------------
    368 
    369   include "cvparam.h"
    370 
    371   ! inputs:
    372   INTEGER len, nd, icb(len)
    373   REAL cbmf(len), tv(len, nd), tvp(len, nd)
    374 
    375   ! outputs:
    376   INTEGER iflag(len) ! also an input
    377 
    378   ! local variables:
    379   INTEGER i
    380 
    381   DO i = 1, len
    382     IF ((cbmf(i)==0.0) .AND. (iflag(i)==0) .AND. (tvp(i, &
    383             icb(i))<=(tv(i, icb(i)) - dtmax))) iflag(i) = 4
    384   END DO
    385 
    386 END SUBROUTINE cv_trigger
    387 
    388 SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, nk1, icb1, cbmf1, plcl1, &
    389         tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, tv1, &
    390         tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, q, qs, u, &
    391         v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, dph)
    392   USE lmdz_print_control, ONLY: lunout
    393   USE lmdz_abort_physic, ONLY: abort_physic
    394   IMPLICIT NONE
    395 
    396   include "cvparam.h"
    397 
    398   ! inputs:
    399   INTEGER len, ncum, nd, nloc
    400   INTEGER iflag1(len), nk1(len), icb1(len)
    401   REAL cbmf1(len), plcl1(len), tnk1(len), qnk1(len), gznk1(len)
    402   REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
    403   REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
    404   REAL p1(len, nd), ph1(len, nd + 1), tv1(len, nd), tp1(len, nd)
    405   REAL tvp1(len, nd), clw1(len, nd)
    406 
    407   ! outputs:
    408   INTEGER iflag(nloc), nk(nloc), icb(nloc)
    409   REAL cbmf(nloc), plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
    410   REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
    411   REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
    412   REAL p(nloc, nd), ph(nloc, nd + 1), tv(nloc, nd), tp(nloc, nd)
    413   REAL tvp(nloc, nd), clw(nloc, nd)
    414   REAL dph(nloc, nd)
    415 
    416   ! local variables:
    417   INTEGER i, k, nn
    418   CHARACTER (LEN = 20) :: modname = 'cv_compress'
    419   CHARACTER (LEN = 80) :: abort_message
    420 
    421   DO k = 1, nl + 1
     475
    422476    nn = 0
    423477    DO i = 1, len
    424478      IF (iflag1(i)==0) THEN
    425479        nn = nn + 1
    426         t(nn, k) = t1(i, k)
    427         q(nn, k) = q1(i, k)
    428         qs(nn, k) = qs1(i, k)
    429         u(nn, k) = u1(i, k)
    430         v(nn, k) = v1(i, k)
    431         gz(nn, k) = gz1(i, k)
    432         h(nn, k) = h1(i, k)
    433         lv(nn, k) = lv1(i, k)
    434         cpn(nn, k) = cpn1(i, k)
    435         p(nn, k) = p1(i, k)
    436         ph(nn, k) = ph1(i, k)
    437         tv(nn, k) = tv1(i, k)
    438         tp(nn, k) = tp1(i, k)
    439         tvp(nn, k) = tvp1(i, k)
    440         clw(nn, k) = clw1(i, k)
     480        cbmf(nn) = cbmf1(i)
     481        plcl(nn) = plcl1(i)
     482        tnk(nn) = tnk1(i)
     483        qnk(nn) = qnk1(i)
     484        gznk(nn) = gznk1(i)
     485        nk(nn) = nk1(i)
     486        icb(nn) = icb1(i)
     487        iflag(nn) = iflag1(i)
    441488      END IF
    442489    END DO
    443   END DO
    444 
    445   IF (nn/=ncum) THEN
    446     WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
    447     abort_message = ''
    448     CALL abort_physic(modname, abort_message, 1)
    449   END IF
    450 
    451   nn = 0
    452   DO i = 1, len
    453     IF (iflag1(i)==0) THEN
    454       nn = nn + 1
    455       cbmf(nn) = cbmf1(i)
    456       plcl(nn) = plcl1(i)
    457       tnk(nn) = tnk1(i)
    458       qnk(nn) = qnk1(i)
    459       gznk(nn) = gznk1(i)
    460       nk(nn) = nk1(i)
    461       icb(nn) = icb1(i)
    462       iflag(nn) = iflag1(i)
    463     END IF
    464   END DO
    465 
    466   DO k = 1, nl
    467     DO i = 1, ncum
    468       dph(i, k) = ph(i, k) - ph(i, k + 1)
    469     END DO
    470   END DO
    471 
    472 END SUBROUTINE cv_compress
    473 
    474 SUBROUTINE cv_undilute2(nloc, ncum, nd, icb, nk, tnk, qnk, gznk, t, q, qs, &
    475         gz, p, dph, h, tv, lv, inb, inb1, tp, tvp, clw, hp, ep, sigp, frac)
    476   USE lmdz_cvthermo
    477 
    478   IMPLICIT NONE
    479 
    480   ! ---------------------------------------------------------------------
    481   ! Purpose:
    482   ! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
    483   ! &
    484   ! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
    485   ! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
    486   ! &
    487   ! FIND THE LEVEL OF NEUTRAL BUOYANCY
    488   ! ---------------------------------------------------------------------
    489 
    490   include "cvparam.h"
    491 
    492   ! inputs:
    493   INTEGER ncum, nd, nloc
    494   INTEGER icb(nloc), nk(nloc)
    495   REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
    496   REAL p(nloc, nd), dph(nloc, nd)
    497   REAL tnk(nloc), qnk(nloc), gznk(nloc)
    498   REAL lv(nloc, nd), tv(nloc, nd), h(nloc, nd)
    499 
    500   ! outputs:
    501   INTEGER inb(nloc), inb1(nloc)
    502   REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
    503   REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
    504   REAL frac(nloc)
    505 
    506   ! local variables:
    507   INTEGER i, k
    508   REAL tg, qg, ahg, alv, s, tc, es, denom, rg, tca, elacrit
    509   REAL by, defrac
    510   REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
    511   LOGICAL lcape(nloc)
    512 
    513   ! =====================================================================
    514   ! --- SOME INITIALIZATIONS
    515   ! =====================================================================
    516 
    517   DO k = 1, nl
    518     DO i = 1, ncum
    519       ep(i, k) = 0.0
    520       sigp(i, k) = sigs
    521     END DO
    522   END DO
    523 
    524   ! =====================================================================
    525   ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
    526   ! =====================================================================
    527 
    528   ! ---       The procedure is to solve the equation.
    529   ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
    530 
    531   ! ***  Calculate certain parcel quantities, including static energy   ***
    532 
    533   DO i = 1, ncum
    534     ah0(i) = (cpd * (1. - qnk(i)) + cl * qnk(i)) * tnk(i) + qnk(i) * (lv0 - clmcpv * (tnk(i) - &
    535             t0)) + gznk(i)
    536   END DO
    537 
    538 
    539   ! ***  Find lifted parcel quantities above cloud base    ***
    540 
    541   DO k = minorig + 1, nl
    542     DO i = 1, ncum
    543       IF (k>=(icb(i) + 1)) THEN
    544         tg = t(i, k)
    545         qg = qs(i, k)
    546         alv = lv0 - clmcpv * (t(i, k) - t0)
    547 
    548         ! First iteration.
    549 
    550         s = cpd + alv * alv * qg / (rrv * t(i, k) * t(i, k))
    551         s = 1. / s
    552         ahg = cpd * tg + (cl - cpd) * qnk(i) * t(i, k) + alv * qg + gz(i, k)
    553         tg = tg + s * (ah0(i) - ahg)
    554         tg = max(tg, 35.0)
    555         tc = tg - t0
    556         denom = 243.5 + tc
    557         IF (tc>=0.0) THEN
    558           es = 6.112 * exp(17.67 * tc / denom)
    559         ELSE
    560           es = exp(23.33086 - 6111.72784 / tg + 0.15215 * log(tg))
    561         END IF
    562         qg = eps * es / (p(i, k) - es * (1. - eps))
    563 
    564         ! Second iteration.
    565 
    566         s = cpd + alv * alv * qg / (rrv * t(i, k) * t(i, k))
    567         s = 1. / s
    568         ahg = cpd * tg + (cl - cpd) * qnk(i) * t(i, k) + alv * qg + gz(i, k)
    569         tg = tg + s * (ah0(i) - ahg)
    570         tg = max(tg, 35.0)
    571         tc = tg - t0
    572         denom = 243.5 + tc
    573         IF (tc>=0.0) THEN
    574           es = 6.112 * exp(17.67 * tc / denom)
    575         ELSE
    576           es = exp(23.33086 - 6111.72784 / tg + 0.15215 * log(tg))
    577         END IF
    578         qg = eps * es / (p(i, k) - es * (1. - eps))
    579 
    580         alv = lv0 - clmcpv * (t(i, k) - t0)
    581         ! PRINT*,'cpd dans convect2 ',cpd
    582         ! PRINT*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
    583         ! PRINT*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
    584         tp(i, k) = (ah0(i) - (cl - cpd) * qnk(i) * t(i, k) - gz(i, k) - alv * qg) / cpd
    585         ! if (.NOT.cpd.gt.1000.) THEN
    586         ! PRINT*,'CPD=',cpd
    587         ! stop
    588         ! END IF
    589         clw(i, k) = qnk(i) - qg
    590         clw(i, k) = max(0.0, clw(i, k))
    591         rg = qg / (1. - qnk(i))
    592         tvp(i, k) = tp(i, k) * (1. + rg * epsi)
     490
     491    DO k = 1, nl
     492      DO i = 1, ncum
     493        dph(i, k) = ph(i, k) - ph(i, k + 1)
     494      END DO
     495    END DO
     496
     497  END SUBROUTINE cv_compress
     498
     499  SUBROUTINE cv_undilute2(nloc, ncum, nd, icb, nk, tnk, qnk, gznk, t, q, qs, &
     500          gz, p, dph, h, tv, lv, inb, inb1, tp, tvp, clw, hp, ep, sigp, frac)
     501    USE lmdz_cvthermo
     502
     503    IMPLICIT NONE
     504
     505    ! ---------------------------------------------------------------------
     506    ! Purpose:
     507    ! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
     508    ! &
     509    ! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
     510    ! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
     511    ! &
     512    ! FIND THE LEVEL OF NEUTRAL BUOYANCY
     513    ! ---------------------------------------------------------------------
     514
     515
     516    ! inputs:
     517    INTEGER ncum, nd, nloc
     518    INTEGER icb(nloc), nk(nloc)
     519    REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
     520    REAL p(nloc, nd), dph(nloc, nd)
     521    REAL tnk(nloc), qnk(nloc), gznk(nloc)
     522    REAL lv(nloc, nd), tv(nloc, nd), h(nloc, nd)
     523
     524    ! outputs:
     525    INTEGER inb(nloc), inb1(nloc)
     526    REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
     527    REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
     528    REAL frac(nloc)
     529
     530    ! local variables:
     531    INTEGER i, k
     532    REAL tg, qg, ahg, alv, s, tc, es, denom, rg, tca, elacrit
     533    REAL by, defrac
     534    REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
     535    LOGICAL lcape(nloc)
     536
     537    ! =====================================================================
     538    ! --- SOME INITIALIZATIONS
     539    ! =====================================================================
     540
     541    DO k = 1, nl
     542      DO i = 1, ncum
     543        ep(i, k) = 0.0
     544        sigp(i, k) = sigs
     545      END DO
     546    END DO
     547
     548    ! =====================================================================
     549    ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
     550    ! =====================================================================
     551
     552    ! ---       The procedure is to solve the equation.
     553    ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
     554
     555    ! ***  Calculate certain parcel quantities, including static energy   ***
     556
     557    DO i = 1, ncum
     558      ah0(i) = (cpd * (1. - qnk(i)) + cl * qnk(i)) * tnk(i) + qnk(i) * (lv0 - clmcpv * (tnk(i) - &
     559              t0)) + gznk(i)
     560    END DO
     561
     562
     563    ! ***  Find lifted parcel quantities above cloud base    ***
     564
     565    DO k = minorig + 1, nl
     566      DO i = 1, ncum
     567        IF (k>=(icb(i) + 1)) THEN
     568          tg = t(i, k)
     569          qg = qs(i, k)
     570          alv = lv0 - clmcpv * (t(i, k) - t0)
     571
     572          ! First iteration.
     573
     574          s = cpd + alv * alv * qg / (rrv * t(i, k) * t(i, k))
     575          s = 1. / s
     576          ahg = cpd * tg + (cl - cpd) * qnk(i) * t(i, k) + alv * qg + gz(i, k)
     577          tg = tg + s * (ah0(i) - ahg)
     578          tg = max(tg, 35.0)
     579          tc = tg - t0
     580          denom = 243.5 + tc
     581          IF (tc>=0.0) THEN
     582            es = 6.112 * exp(17.67 * tc / denom)
     583          ELSE
     584            es = exp(23.33086 - 6111.72784 / tg + 0.15215 * log(tg))
     585          END IF
     586          qg = eps * es / (p(i, k) - es * (1. - eps))
     587
     588          ! Second iteration.
     589
     590          s = cpd + alv * alv * qg / (rrv * t(i, k) * t(i, k))
     591          s = 1. / s
     592          ahg = cpd * tg + (cl - cpd) * qnk(i) * t(i, k) + alv * qg + gz(i, k)
     593          tg = tg + s * (ah0(i) - ahg)
     594          tg = max(tg, 35.0)
     595          tc = tg - t0
     596          denom = 243.5 + tc
     597          IF (tc>=0.0) THEN
     598            es = 6.112 * exp(17.67 * tc / denom)
     599          ELSE
     600            es = exp(23.33086 - 6111.72784 / tg + 0.15215 * log(tg))
     601          END IF
     602          qg = eps * es / (p(i, k) - es * (1. - eps))
     603
     604          alv = lv0 - clmcpv * (t(i, k) - t0)
     605          ! PRINT*,'cpd dans convect2 ',cpd
     606          ! PRINT*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
     607          ! PRINT*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
     608          tp(i, k) = (ah0(i) - (cl - cpd) * qnk(i) * t(i, k) - gz(i, k) - alv * qg) / cpd
     609          ! if (.NOT.cpd.gt.1000.) THEN
     610          ! PRINT*,'CPD=',cpd
     611          ! stop
     612          ! END IF
     613          clw(i, k) = qnk(i) - qg
     614          clw(i, k) = max(0.0, clw(i, k))
     615          rg = qg / (1. - qnk(i))
     616          tvp(i, k) = tp(i, k) * (1. + rg * epsi)
     617        END IF
     618      END DO
     619    END DO
     620
     621    ! =====================================================================
     622    ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
     623    ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
     624    ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
     625    ! =====================================================================
     626
     627    DO k = minorig + 1, nl
     628      DO i = 1, ncum
     629        IF (k>=(nk(i) + 1)) THEN
     630          tca = tp(i, k) - t0
     631          IF (tca>=0.0) THEN
     632            elacrit = elcrit
     633          ELSE
     634            elacrit = elcrit * (1.0 - tca / tlcrit)
     635          END IF
     636          elacrit = max(elacrit, 0.0)
     637          ep(i, k) = 1.0 - elacrit / max(clw(i, k), 1.0E-8)
     638          ep(i, k) = max(ep(i, k), 0.0)
     639          ep(i, k) = min(ep(i, k), 1.0)
     640          sigp(i, k) = sigs
     641        END IF
     642      END DO
     643    END DO
     644
     645    ! =====================================================================
     646    ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
     647    ! --- VIRTUAL TEMPERATURE
     648    ! =====================================================================
     649
     650    DO k = minorig + 1, nl
     651      DO i = 1, ncum
     652        IF (k>=(icb(i) + 1)) THEN
     653          tvp(i, k) = tvp(i, k) * (1.0 - qnk(i) + ep(i, k) * clw(i, k))
     654          ! PRINT*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
     655          ! PRINT*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
     656        END IF
     657      END DO
     658    END DO
     659    DO i = 1, ncum
     660      tvp(i, nlp) = tvp(i, nl) - (gz(i, nlp) - gz(i, nl)) / cpd
     661    END DO
     662
     663    ! =====================================================================
     664    ! --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
     665    ! --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
     666    ! --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
     667    ! =====================================================================
     668
     669    DO i = 1, ncum
     670      cape(i) = 0.0
     671      capem(i) = 0.0
     672      inb(i) = icb(i) + 1
     673      inb1(i) = inb(i)
     674    END DO
     675
     676    ! Originial Code
     677
     678    ! do 530 k=minorig+1,nl-1
     679    ! do 520 i=1,ncum
     680    ! IF(k.ge.(icb(i)+1))THEN
     681    ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
     682    ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
     683    ! cape(i)=cape(i)+by
     684    ! IF(by.ge.0.0)inb1(i)=k+1
     685    ! IF(cape(i).gt.0.0)THEN
     686    ! inb(i)=k+1
     687    ! capem(i)=cape(i)
     688    ! END IF
     689    ! END IF
     690    ! 520    continue
     691    ! 530  continue
     692    ! do 540 i=1,ncum
     693    ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
     694    ! cape(i)=capem(i)+byp
     695    ! defrac=capem(i)-cape(i)
     696    ! defrac=max(defrac,0.001)
     697    ! frac(i)=-cape(i)/defrac
     698    ! frac(i)=min(frac(i),1.0)
     699    ! frac(i)=max(frac(i),0.0)
     700    ! 540   continue
     701
     702    ! K Emanuel fix
     703
     704    ! CALL zilch(byp,ncum)
     705    ! do 530 k=minorig+1,nl-1
     706    ! do 520 i=1,ncum
     707    ! IF(k.ge.(icb(i)+1))THEN
     708    ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
     709    ! cape(i)=cape(i)+by
     710    ! IF(by.ge.0.0)inb1(i)=k+1
     711    ! IF(cape(i).gt.0.0)THEN
     712    ! inb(i)=k+1
     713    ! capem(i)=cape(i)
     714    ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
     715    ! END IF
     716    ! END IF
     717    ! 520    continue
     718    ! 530  continue
     719    ! do 540 i=1,ncum
     720    ! inb(i)=max(inb(i),inb1(i))
     721    ! cape(i)=capem(i)+byp(i)
     722    ! defrac=capem(i)-cape(i)
     723    ! defrac=max(defrac,0.001)
     724    ! frac(i)=-cape(i)/defrac
     725    ! frac(i)=min(frac(i),1.0)
     726    ! frac(i)=max(frac(i),0.0)
     727    ! 540   continue
     728
     729    ! J Teixeira fix
     730
     731    CALL zilch(byp, ncum)
     732    DO i = 1, ncum
     733      lcape(i) = .TRUE.
     734    END DO
     735    DO k = minorig + 1, nl - 1
     736      DO i = 1, ncum
     737        IF (cape(i)<0.0) lcape(i) = .FALSE.
     738        IF ((k>=(icb(i) + 1)) .AND. lcape(i)) THEN
     739          by = (tvp(i, k) - tv(i, k)) * dph(i, k) / p(i, k)
     740          byp(i) = (tvp(i, k + 1) - tv(i, k + 1)) * dph(i, k + 1) / p(i, k + 1)
     741          cape(i) = cape(i) + by
     742          IF (by>=0.0) inb1(i) = k + 1
     743          IF (cape(i)>0.0) THEN
     744            inb(i) = k + 1
     745            capem(i) = cape(i)
     746          END IF
     747        END IF
     748      END DO
     749    END DO
     750    DO i = 1, ncum
     751      cape(i) = capem(i) + byp(i)
     752      defrac = capem(i) - cape(i)
     753      defrac = max(defrac, 0.001)
     754      frac(i) = -cape(i) / defrac
     755      frac(i) = min(frac(i), 1.0)
     756      frac(i) = max(frac(i), 0.0)
     757    END DO
     758
     759    ! =====================================================================
     760    ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
     761    ! =====================================================================
     762
     763    ! initialization:
     764    DO i = 1, ncum * nlp
     765      hp(i, 1) = h(i, 1)
     766    END DO
     767
     768    DO k = minorig + 1, nl
     769      DO i = 1, ncum
     770        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
     771          hp(i, k) = h(i, nk(i)) + (lv(i, k) + (cpd - cpv) * t(i, k)) * ep(i, k) * clw(i, k &
     772                  )
     773        END IF
     774      END DO
     775    END DO
     776
     777  END SUBROUTINE cv_undilute2
     778
     779  SUBROUTINE cv_closure(nloc, ncum, nd, nk, icb, tv, tvp, p, ph, dph, plcl, &
     780          cpn, iflag, cbmf)
     781    USE lmdz_cvthermo
     782
     783    IMPLICIT NONE
     784
     785    ! inputs:
     786    INTEGER ncum, nd, nloc
     787    INTEGER nk(nloc), icb(nloc)
     788    REAL tv(nloc, nd), tvp(nloc, nd), p(nloc, nd), dph(nloc, nd)
     789    REAL ph(nloc, nd + 1) ! caution nd instead ndp1 to be consistent...
     790    REAL plcl(nloc), cpn(nloc, nd)
     791
     792    ! outputs:
     793    INTEGER iflag(nloc)
     794    REAL cbmf(nloc) ! also an input
     795
     796    ! local variables:
     797    INTEGER i, k, icbmax
     798    REAL dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
     799    REAL work(nloc)
     800
     801
     802    ! -------------------------------------------------------------------
     803    ! Compute icbmax.
     804    ! -------------------------------------------------------------------
     805
     806    icbmax = 2
     807    DO i = 1, ncum
     808      icbmax = max(icbmax, icb(i))
     809    END DO
     810
     811    ! =====================================================================
     812    ! ---  CALCULATE CLOUD BASE MASS FLUX
     813    ! =====================================================================
     814
     815    ! tvpplcl = parcel temperature lifted adiabatically from level
     816    ! icb-1 to the LCL.
     817    ! tvaplcl = virtual temperature at the LCL.
     818
     819    DO i = 1, ncum
     820      dtpbl(i) = 0.0
     821      tvpplcl(i) = tvp(i, icb(i) - 1) - rrd * tvp(i, icb(i) - 1) * (p(i, icb(i) - 1) - plcl(&
     822              i)) / (cpn(i, icb(i) - 1) * p(i, icb(i) - 1))
     823      tvaplcl(i) = tv(i, icb(i)) + (tvp(i, icb(i)) - tvp(i, icb(i) + 1)) * (plcl(i) - p(i &
     824              , icb(i))) / (p(i, icb(i)) - p(i, icb(i) + 1))
     825    END DO
     826
     827    ! -------------------------------------------------------------------
     828    ! --- Interpolate difference between lifted parcel and
     829    ! --- environmental temperatures to lifted condensation level
     830    ! -------------------------------------------------------------------
     831
     832    ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
     833
     834    DO k = minorig, icbmax
     835      DO i = 1, ncum
     836        IF ((k>=nk(i)) .AND. (k<=(icb(i) - 1))) THEN
     837          dtpbl(i) = dtpbl(i) + (tvp(i, k) - tv(i, k)) * dph(i, k)
     838        END IF
     839      END DO
     840    END DO
     841    DO i = 1, ncum
     842      dtpbl(i) = dtpbl(i) / (ph(i, nk(i)) - ph(i, icb(i)))
     843      dtmin(i) = tvpplcl(i) - tvaplcl(i) + dtmax + dtpbl(i)
     844    END DO
     845
     846    ! -------------------------------------------------------------------
     847    ! --- Adjust cloud base mass flux
     848    ! -------------------------------------------------------------------
     849
     850    DO i = 1, ncum
     851      work(i) = cbmf(i)
     852      cbmf(i) = max(0.0, (1.0 - damp) * cbmf(i) + 0.1 * alpha * dtmin(i))
     853      IF ((work(i)==0.0) .AND. (cbmf(i)==0.0)) THEN
     854        iflag(i) = 3
    593855      END IF
    594856    END DO
    595   END DO
    596 
    597   ! =====================================================================
    598   ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
    599   ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
    600   ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
    601   ! =====================================================================
    602 
    603   DO k = minorig + 1, nl
    604     DO i = 1, ncum
    605       IF (k>=(nk(i) + 1)) THEN
    606         tca = tp(i, k) - t0
    607         IF (tca>=0.0) THEN
    608           elacrit = elcrit
    609         ELSE
    610           elacrit = elcrit * (1.0 - tca / tlcrit)
    611         END IF
    612         elacrit = max(elacrit, 0.0)
    613         ep(i, k) = 1.0 - elacrit / max(clw(i, k), 1.0E-8)
    614         ep(i, k) = max(ep(i, k), 0.0)
    615         ep(i, k) = min(ep(i, k), 1.0)
    616         sigp(i, k) = sigs
    617       END IF
    618     END DO
    619   END DO
    620 
    621   ! =====================================================================
    622   ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
    623   ! --- VIRTUAL TEMPERATURE
    624   ! =====================================================================
    625 
    626   DO k = minorig + 1, nl
    627     DO i = 1, ncum
    628       IF (k>=(icb(i) + 1)) THEN
    629         tvp(i, k) = tvp(i, k) * (1.0 - qnk(i) + ep(i, k) * clw(i, k))
    630         ! PRINT*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
    631         ! PRINT*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
    632       END IF
    633     END DO
    634   END DO
    635   DO i = 1, ncum
    636     tvp(i, nlp) = tvp(i, nl) - (gz(i, nlp) - gz(i, nl)) / cpd
    637   END DO
    638 
    639   ! =====================================================================
    640   ! --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
    641   ! --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
    642   ! --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
    643   ! =====================================================================
    644 
    645   DO i = 1, ncum
    646     cape(i) = 0.0
    647     capem(i) = 0.0
    648     inb(i) = icb(i) + 1
    649     inb1(i) = inb(i)
    650   END DO
    651 
    652   ! Originial Code
    653 
    654   ! do 530 k=minorig+1,nl-1
    655   ! do 520 i=1,ncum
    656   ! IF(k.ge.(icb(i)+1))THEN
    657   ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
    658   ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
    659   ! cape(i)=cape(i)+by
    660   ! IF(by.ge.0.0)inb1(i)=k+1
    661   ! IF(cape(i).gt.0.0)THEN
    662   ! inb(i)=k+1
    663   ! capem(i)=cape(i)
    664   ! END IF
    665   ! END IF
    666   ! 520    continue
    667   ! 530  continue
    668   ! do 540 i=1,ncum
    669   ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
    670   ! cape(i)=capem(i)+byp
    671   ! defrac=capem(i)-cape(i)
    672   ! defrac=max(defrac,0.001)
    673   ! frac(i)=-cape(i)/defrac
    674   ! frac(i)=min(frac(i),1.0)
    675   ! frac(i)=max(frac(i),0.0)
    676   ! 540   continue
    677 
    678   ! K Emanuel fix
    679 
    680   ! CALL zilch(byp,ncum)
    681   ! do 530 k=minorig+1,nl-1
    682   ! do 520 i=1,ncum
    683   ! IF(k.ge.(icb(i)+1))THEN
    684   ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
    685   ! cape(i)=cape(i)+by
    686   ! IF(by.ge.0.0)inb1(i)=k+1
    687   ! IF(cape(i).gt.0.0)THEN
    688   ! inb(i)=k+1
    689   ! capem(i)=cape(i)
    690   ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
    691   ! END IF
    692   ! END IF
    693   ! 520    continue
    694   ! 530  continue
    695   ! do 540 i=1,ncum
    696   ! inb(i)=max(inb(i),inb1(i))
    697   ! cape(i)=capem(i)+byp(i)
    698   ! defrac=capem(i)-cape(i)
    699   ! defrac=max(defrac,0.001)
    700   ! frac(i)=-cape(i)/defrac
    701   ! frac(i)=min(frac(i),1.0)
    702   ! frac(i)=max(frac(i),0.0)
    703   ! 540   continue
    704 
    705   ! J Teixeira fix
    706 
    707   CALL zilch(byp, ncum)
    708   DO i = 1, ncum
    709     lcape(i) = .TRUE.
    710   END DO
    711   DO k = minorig + 1, nl - 1
    712     DO i = 1, ncum
    713       IF (cape(i)<0.0) lcape(i) = .FALSE.
    714       IF ((k>=(icb(i) + 1)) .AND. lcape(i)) THEN
    715         by = (tvp(i, k) - tv(i, k)) * dph(i, k) / p(i, k)
    716         byp(i) = (tvp(i, k + 1) - tv(i, k + 1)) * dph(i, k + 1) / p(i, k + 1)
    717         cape(i) = cape(i) + by
    718         IF (by>=0.0) inb1(i) = k + 1
    719         IF (cape(i)>0.0) THEN
    720           inb(i) = k + 1
    721           capem(i) = cape(i)
    722         END IF
    723       END IF
    724     END DO
    725   END DO
    726   DO i = 1, ncum
    727     cape(i) = capem(i) + byp(i)
    728     defrac = capem(i) - cape(i)
    729     defrac = max(defrac, 0.001)
    730     frac(i) = -cape(i) / defrac
    731     frac(i) = min(frac(i), 1.0)
    732     frac(i) = max(frac(i), 0.0)
    733   END DO
    734 
    735   ! =====================================================================
    736   ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
    737   ! =====================================================================
    738 
    739   ! initialization:
    740   DO i = 1, ncum * nlp
    741     hp(i, 1) = h(i, 1)
    742   END DO
    743 
    744   DO k = minorig + 1, nl
    745     DO i = 1, ncum
    746       IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
    747         hp(i, k) = h(i, nk(i)) + (lv(i, k) + (cpd - cpv) * t(i, k)) * ep(i, k) * clw(i, k &
    748                 )
    749       END IF
    750     END DO
    751   END DO
    752 
    753 END SUBROUTINE cv_undilute2
    754 
    755 SUBROUTINE cv_closure(nloc, ncum, nd, nk, icb, tv, tvp, p, ph, dph, plcl, &
    756         cpn, iflag, cbmf)
    757   USE lmdz_cvthermo
    758 
    759   IMPLICIT NONE
    760 
    761   ! inputs:
    762   INTEGER ncum, nd, nloc
    763   INTEGER nk(nloc), icb(nloc)
    764   REAL tv(nloc, nd), tvp(nloc, nd), p(nloc, nd), dph(nloc, nd)
    765   REAL ph(nloc, nd + 1) ! caution nd instead ndp1 to be consistent...
    766   REAL plcl(nloc), cpn(nloc, nd)
    767 
    768   ! outputs:
    769   INTEGER iflag(nloc)
    770   REAL cbmf(nloc) ! also an input
    771 
    772   ! local variables:
    773   INTEGER i, k, icbmax
    774   REAL dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
    775   REAL work(nloc)
    776 
    777   include "cvparam.h"
    778 
    779   ! -------------------------------------------------------------------
    780   ! Compute icbmax.
    781   ! -------------------------------------------------------------------
    782 
    783   icbmax = 2
    784   DO i = 1, ncum
    785     icbmax = max(icbmax, icb(i))
    786   END DO
    787 
    788   ! =====================================================================
    789   ! ---  CALCULATE CLOUD BASE MASS FLUX
    790   ! =====================================================================
    791 
    792   ! tvpplcl = parcel temperature lifted adiabatically from level
    793   ! icb-1 to the LCL.
    794   ! tvaplcl = virtual temperature at the LCL.
    795 
    796   DO i = 1, ncum
    797     dtpbl(i) = 0.0
    798     tvpplcl(i) = tvp(i, icb(i) - 1) - rrd * tvp(i, icb(i) - 1) * (p(i, icb(i) - 1) - plcl(&
    799             i)) / (cpn(i, icb(i) - 1) * p(i, icb(i) - 1))
    800     tvaplcl(i) = tv(i, icb(i)) + (tvp(i, icb(i)) - tvp(i, icb(i) + 1)) * (plcl(i) - p(i &
    801             , icb(i))) / (p(i, icb(i)) - p(i, icb(i) + 1))
    802   END DO
    803 
    804   ! -------------------------------------------------------------------
    805   ! --- Interpolate difference between lifted parcel and
    806   ! --- environmental temperatures to lifted condensation level
    807   ! -------------------------------------------------------------------
    808 
    809   ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
    810 
    811   DO k = minorig, icbmax
    812     DO i = 1, ncum
    813       IF ((k>=nk(i)) .AND. (k<=(icb(i) - 1))) THEN
    814         dtpbl(i) = dtpbl(i) + (tvp(i, k) - tv(i, k)) * dph(i, k)
    815       END IF
    816     END DO
    817   END DO
    818   DO i = 1, ncum
    819     dtpbl(i) = dtpbl(i) / (ph(i, nk(i)) - ph(i, icb(i)))
    820     dtmin(i) = tvpplcl(i) - tvaplcl(i) + dtmax + dtpbl(i)
    821   END DO
    822 
    823   ! -------------------------------------------------------------------
    824   ! --- Adjust cloud base mass flux
    825   ! -------------------------------------------------------------------
    826 
    827   DO i = 1, ncum
    828     work(i) = cbmf(i)
    829     cbmf(i) = max(0.0, (1.0 - damp) * cbmf(i) + 0.1 * alpha * dtmin(i))
    830     IF ((work(i)==0.0) .AND. (cbmf(i)==0.0)) THEN
    831       iflag(i) = 3
    832     END IF
    833   END DO
    834 
    835 END SUBROUTINE cv_closure
    836 
    837 SUBROUTINE cv_mixing(nloc, ncum, nd, icb, nk, inb, inb1, ph, t, q, qs, u, v, &
    838         h, lv, qnk, hp, tv, tvp, ep, clw, cbmf, m, ment, qent, uent, vent, nent, &
    839         sij, elij)
    840   USE lmdz_cvthermo
    841 
    842   IMPLICIT NONE
    843 
    844   include "cvparam.h"
    845 
    846   ! inputs:
    847   INTEGER ncum, nd, nloc
    848   INTEGER icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
    849   REAL cbmf(nloc), qnk(nloc)
    850   REAL ph(nloc, nd + 1)
    851   REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), lv(nloc, nd)
    852   REAL u(nloc, nd), v(nloc, nd), h(nloc, nd), hp(nloc, nd)
    853   REAL tv(nloc, nd), tvp(nloc, nd), ep(nloc, nd), clw(nloc, nd)
    854 
    855   ! outputs:
    856   INTEGER nent(nloc, nd)
    857   REAL m(nloc, nd), ment(nloc, nd, nd), qent(nloc, nd, nd)
    858   REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
    859   REAL sij(nloc, nd, nd), elij(nloc, nd, nd)
    860 
    861   ! local variables:
    862   INTEGER i, j, k, ij
    863   INTEGER num1, num2
    864   REAL dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
    865   REAL alt, qp1, smid, sjmin, sjmax, delp, delm
    866   REAL work(nloc), asij(nloc), smin(nloc), scrit(nloc)
    867   REAL bsum(nloc, nd)
    868   LOGICAL lwork(nloc)
    869 
    870   ! =====================================================================
    871   ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
    872   ! =====================================================================
    873 
    874   DO i = 1, ncum * nlp
    875     nent(i, 1) = 0
    876     m(i, 1) = 0.0
    877   END DO
    878 
    879   DO k = 1, nlp
    880     DO j = 1, nlp
     857
     858  END SUBROUTINE cv_closure
     859
     860  SUBROUTINE cv_mixing(nloc, ncum, nd, icb, nk, inb, inb1, ph, t, q, qs, u, v, &
     861          h, lv, qnk, hp, tv, tvp, ep, clw, cbmf, m, ment, qent, uent, vent, nent, &
     862          sij, elij)
     863    USE lmdz_cvthermo
     864
     865    IMPLICIT NONE
     866
     867
     868    ! inputs:
     869    INTEGER ncum, nd, nloc
     870    INTEGER icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
     871    REAL cbmf(nloc), qnk(nloc)
     872    REAL ph(nloc, nd + 1)
     873    REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), lv(nloc, nd)
     874    REAL u(nloc, nd), v(nloc, nd), h(nloc, nd), hp(nloc, nd)
     875    REAL tv(nloc, nd), tvp(nloc, nd), ep(nloc, nd), clw(nloc, nd)
     876
     877    ! outputs:
     878    INTEGER nent(nloc, nd)
     879    REAL m(nloc, nd), ment(nloc, nd, nd), qent(nloc, nd, nd)
     880    REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
     881    REAL sij(nloc, nd, nd), elij(nloc, nd, nd)
     882
     883    ! local variables:
     884    INTEGER i, j, k, ij
     885    INTEGER num1, num2
     886    REAL dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
     887    REAL alt, qp1, smid, sjmin, sjmax, delp, delm
     888    REAL work(nloc), asij(nloc), smin(nloc), scrit(nloc)
     889    REAL bsum(nloc, nd)
     890    LOGICAL lwork(nloc)
     891
     892    ! =====================================================================
     893    ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
     894    ! =====================================================================
     895
     896    DO i = 1, ncum * nlp
     897      nent(i, 1) = 0
     898      m(i, 1) = 0.0
     899    END DO
     900
     901    DO k = 1, nlp
     902      DO j = 1, nlp
     903        DO i = 1, ncum
     904          qent(i, k, j) = q(i, j)
     905          uent(i, k, j) = u(i, j)
     906          vent(i, k, j) = v(i, j)
     907          elij(i, k, j) = 0.0
     908          ment(i, k, j) = 0.0
     909          sij(i, k, j) = 0.0
     910        END DO
     911      END DO
     912    END DO
     913
     914    ! -------------------------------------------------------------------
     915    ! --- Calculate rates of mixing,  m(i)
     916    ! -------------------------------------------------------------------
     917
     918    CALL zilch(work, ncum)
     919
     920    DO j = minorig + 1, nl
    881921      DO i = 1, ncum
    882         qent(i, k, j) = q(i, j)
    883         uent(i, k, j) = u(i, j)
    884         vent(i, k, j) = v(i, j)
    885         elij(i, k, j) = 0.0
    886         ment(i, k, j) = 0.0
    887         sij(i, k, j) = 0.0
    888       END DO
    889     END DO
    890   END DO
    891 
    892   ! -------------------------------------------------------------------
    893   ! --- Calculate rates of mixing,  m(i)
    894   ! -------------------------------------------------------------------
    895 
    896   CALL zilch(work, ncum)
    897 
    898   DO j = minorig + 1, nl
    899     DO i = 1, ncum
    900       IF ((j>=(icb(i) + 1)) .AND. (j<=inb(i))) THEN
    901         k = min(j, inb1(i))
    902         dbo = abs(tv(i, k + 1) - tvp(i, k + 1) - tv(i, k - 1) + tvp(i, k - 1)) + &
    903                 entp * 0.04 * (ph(i, k) - ph(i, k + 1))
    904         work(i) = work(i) + dbo
    905         m(i, j) = cbmf(i) * dbo
    906       END IF
    907     END DO
    908   END DO
    909   DO k = minorig + 1, nl
    910     DO i = 1, ncum
    911       IF ((k>=(icb(i) + 1)) .AND. (k<=inb(i))) THEN
    912         m(i, k) = m(i, k) / work(i)
    913       END IF
    914     END DO
    915   END DO
    916 
    917 
    918   ! =====================================================================
    919   ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
    920   ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
    921   ! --- FRACTION (sij)
    922   ! =====================================================================
    923 
    924   DO i = minorig + 1, nl
    925     DO j = minorig + 1, nl
    926       DO ij = 1, ncum
    927         IF ((i>=(icb(ij) + 1)) .AND. (j>=icb(ij)) .AND. (i<=inb(ij)) .AND. (j<= &
    928                 inb(ij))) THEN
    929           qti = qnk(ij) - ep(ij, i) * clw(ij, i)
    930           bf2 = 1. + lv(ij, j) * lv(ij, j) * qs(ij, j) / (rrv * t(ij, j) * t(ij, j) * cpd)
    931           anum = h(ij, j) - hp(ij, i) + (cpv - cpd) * t(ij, j) * (qti - q(ij, j))
    932           denom = h(ij, i) - hp(ij, i) + (cpd - cpv) * (q(ij, i) - qti) * t(ij, j)
    933           dei = denom
    934           IF (abs(dei)<0.01) dei = 0.01
    935           sij(ij, i, j) = anum / dei
    936           sij(ij, i, i) = 1.0
    937           altem = sij(ij, i, j) * q(ij, i) + (1. - sij(ij, i, j)) * qti - qs(ij, j)
    938           altem = altem / bf2
    939           cwat = clw(ij, j) * (1. - ep(ij, j))
    940           stemp = sij(ij, i, j)
    941           IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
    942             anum = anum - lv(ij, j) * (qti - qs(ij, j) - cwat * bf2)
    943             denom = denom + lv(ij, j) * (q(ij, i) - qti)
    944             IF (abs(denom)<0.01) denom = 0.01
    945             sij(ij, i, j) = anum / denom
     922        IF ((j>=(icb(i) + 1)) .AND. (j<=inb(i))) THEN
     923          k = min(j, inb1(i))
     924          dbo = abs(tv(i, k + 1) - tvp(i, k + 1) - tv(i, k - 1) + tvp(i, k - 1)) + &
     925                  entp * 0.04 * (ph(i, k) - ph(i, k + 1))
     926          work(i) = work(i) + dbo
     927          m(i, j) = cbmf(i) * dbo
     928        END IF
     929      END DO
     930    END DO
     931    DO k = minorig + 1, nl
     932      DO i = 1, ncum
     933        IF ((k>=(icb(i) + 1)) .AND. (k<=inb(i))) THEN
     934          m(i, k) = m(i, k) / work(i)
     935        END IF
     936      END DO
     937    END DO
     938
     939
     940    ! =====================================================================
     941    ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
     942    ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
     943    ! --- FRACTION (sij)
     944    ! =====================================================================
     945
     946    DO i = minorig + 1, nl
     947      DO j = minorig + 1, nl
     948        DO ij = 1, ncum
     949          IF ((i>=(icb(ij) + 1)) .AND. (j>=icb(ij)) .AND. (i<=inb(ij)) .AND. (j<= &
     950                  inb(ij))) THEN
     951            qti = qnk(ij) - ep(ij, i) * clw(ij, i)
     952            bf2 = 1. + lv(ij, j) * lv(ij, j) * qs(ij, j) / (rrv * t(ij, j) * t(ij, j) * cpd)
     953            anum = h(ij, j) - hp(ij, i) + (cpv - cpd) * t(ij, j) * (qti - q(ij, j))
     954            denom = h(ij, i) - hp(ij, i) + (cpd - cpv) * (q(ij, i) - qti) * t(ij, j)
     955            dei = denom
     956            IF (abs(dei)<0.01) dei = 0.01
     957            sij(ij, i, j) = anum / dei
     958            sij(ij, i, i) = 1.0
    946959            altem = sij(ij, i, j) * q(ij, i) + (1. - sij(ij, i, j)) * qti - qs(ij, j)
    947             altem = altem - (bf2 - 1.) * cwat
    948           END IF
    949           IF (sij(ij, i, j)>0.0 .AND. sij(ij, i, j)<0.9) THEN
    950             qent(ij, i, j) = sij(ij, i, j) * q(ij, i) + (1. - sij(ij, i, j)) * qti
    951             uent(ij, i, j) = sij(ij, i, j) * u(ij, i) + &
    952                     (1. - sij(ij, i, j)) * u(ij, nk(ij))
    953             vent(ij, i, j) = sij(ij, i, j) * v(ij, i) + &
    954                     (1. - sij(ij, i, j)) * v(ij, nk(ij))
    955             elij(ij, i, j) = altem
    956             elij(ij, i, j) = max(0.0, elij(ij, i, j))
    957             ment(ij, i, j) = m(ij, i) / (1. - sij(ij, i, j))
    958             nent(ij, i) = nent(ij, i) + 1
    959           END IF
    960           sij(ij, i, j) = max(0.0, sij(ij, i, j))
    961           sij(ij, i, j) = min(1.0, sij(ij, i, j))
    962         END IF
    963       END DO
    964     END DO
    965 
    966     ! ***   If no air can entrain at level i assume that updraft detrains
    967     ! ***
    968     ! ***   at that level and calculate detrained air flux and properties
    969     ! ***
    970 
    971     DO ij = 1, ncum
    972       IF ((i>=(icb(ij) + 1)) .AND. (i<=inb(ij)) .AND. (nent(ij, i)==0)) THEN
    973         ment(ij, i, i) = m(ij, i)
    974         qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i) * clw(ij, i)
    975         uent(ij, i, i) = u(ij, nk(ij))
    976         vent(ij, i, i) = v(ij, nk(ij))
    977         elij(ij, i, i) = clw(ij, i)
    978         sij(ij, i, i) = 1.0
    979       END IF
    980     END DO
    981   END DO
    982 
    983   DO i = 1, ncum
    984     sij(i, inb(i), inb(i)) = 1.0
    985   END DO
    986 
    987   ! =====================================================================
    988   ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
    989   ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
    990   ! =====================================================================
    991 
    992   CALL zilch(bsum, ncum * nlp)
    993   DO ij = 1, ncum
    994     lwork(ij) = .FALSE.
    995   END DO
    996   DO i = minorig + 1, nl
    997 
    998     num1 = 0
    999     DO ij = 1, ncum
    1000       IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij))) num1 = num1 + 1
    1001     END DO
    1002     IF (num1<=0) GO TO 789
    1003 
    1004     DO ij = 1, ncum
    1005       IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij))) THEN
    1006         lwork(ij) = (nent(ij, i)/=0)
    1007         qp1 = q(ij, nk(ij)) - ep(ij, i) * clw(ij, i)
    1008         anum = h(ij, i) - hp(ij, i) - lv(ij, i) * (qp1 - qs(ij, i))
    1009         denom = h(ij, i) - hp(ij, i) + lv(ij, i) * (q(ij, i) - qp1)
    1010         IF (abs(denom)<0.01) denom = 0.01
    1011         scrit(ij) = anum / denom
    1012         alt = qp1 - qs(ij, i) + scrit(ij) * (q(ij, i) - qp1)
    1013         IF (scrit(ij)<0.0 .OR. alt<0.0) scrit(ij) = 1.0
    1014         asij(ij) = 0.0
    1015         smin(ij) = 1.0
    1016       END IF
    1017     END DO
    1018     DO j = minorig, nl
    1019 
    1020       num2 = 0
    1021       DO ij = 1, ncum
    1022         IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij)) .AND. (j>=icb(&
    1023                 ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1
    1024       END DO
    1025       IF (num2<=0) GO TO 783
    1026 
    1027       DO ij = 1, ncum
    1028         IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij)) .AND. (j>=icb(&
    1029                 ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
    1030           IF (sij(ij, i, j)>0.0 .AND. sij(ij, i, j)<0.9) THEN
    1031             IF (j>i) THEN
    1032               smid = min(sij(ij, i, j), scrit(ij))
    1033               sjmax = smid
    1034               sjmin = smid
    1035               IF (smid<smin(ij) .AND. sij(ij, i, j + 1)<smid) THEN
    1036                 smin(ij) = smid
    1037                 sjmax = min(sij(ij, i, j + 1), sij(ij, i, j), scrit(ij))
    1038                 sjmin = max(sij(ij, i, j - 1), sij(ij, i, j))
    1039                 sjmin = min(sjmin, scrit(ij))
    1040               END IF
    1041             ELSE
    1042               sjmax = max(sij(ij, i, j + 1), scrit(ij))
    1043               smid = max(sij(ij, i, j), scrit(ij))
    1044               sjmin = 0.0
    1045               IF (j>1) sjmin = sij(ij, i, j - 1)
    1046               sjmin = max(sjmin, scrit(ij))
     960            altem = altem / bf2
     961            cwat = clw(ij, j) * (1. - ep(ij, j))
     962            stemp = sij(ij, i, j)
     963            IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
     964              anum = anum - lv(ij, j) * (qti - qs(ij, j) - cwat * bf2)
     965              denom = denom + lv(ij, j) * (q(ij, i) - qti)
     966              IF (abs(denom)<0.01) denom = 0.01
     967              sij(ij, i, j) = anum / denom
     968              altem = sij(ij, i, j) * q(ij, i) + (1. - sij(ij, i, j)) * qti - qs(ij, j)
     969              altem = altem - (bf2 - 1.) * cwat
    1047970            END IF
    1048             delp = abs(sjmax - smid)
    1049             delm = abs(sjmin - smid)
    1050             asij(ij) = asij(ij) + (delp + delm) * (ph(ij, j) - ph(ij, j + 1))
    1051             ment(ij, i, j) = ment(ij, i, j) * (delp + delm) * (ph(ij, j) - ph(ij, j + 1))
    1052           END IF
    1053         END IF
    1054       END DO
    1055     783 END DO
    1056     DO ij = 1, ncum
    1057       IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij)) .AND. lwork(ij)) THEN
    1058         asij(ij) = max(1.0E-21, asij(ij))
    1059         asij(ij) = 1.0 / asij(ij)
    1060         bsum(ij, i) = 0.0
    1061       END IF
    1062     END DO
    1063     DO j = minorig, nl + 1
    1064       DO ij = 1, ncum
    1065         IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij)) .AND. (j>=icb(&
    1066                 ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
    1067           ment(ij, i, j) = ment(ij, i, j) * asij(ij)
    1068           bsum(ij, i) = bsum(ij, i) + ment(ij, i, j)
    1069         END IF
    1070       END DO
    1071     END DO
    1072     DO ij = 1, ncum
    1073       IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij)) .AND. (bsum(ij, &
    1074               i)<1.0E-18) .AND. lwork(ij)) THEN
    1075         nent(ij, i) = 0
    1076         ment(ij, i, i) = m(ij, i)
    1077         qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i) * clw(ij, i)
    1078         uent(ij, i, i) = u(ij, nk(ij))
    1079         vent(ij, i, i) = v(ij, nk(ij))
    1080         elij(ij, i, i) = clw(ij, i)
    1081         sij(ij, i, i) = 1.0
    1082       END IF
    1083     END DO
    1084   789 END DO
    1085 
    1086 END SUBROUTINE cv_mixing
    1087 
    1088 SUBROUTINE cv_unsat(nloc, ncum, nd, inb, t, q, qs, gz, u, v, p, ph, h, lv, &
    1089         ep, sigp, clw, m, ment, elij, iflag, mp, qp, up, vp, wt, water, evap)
    1090   USE lmdz_cvthermo
    1091 
    1092   IMPLICIT NONE
    1093 
    1094   include "cvparam.h"
    1095 
    1096   ! inputs:
    1097   INTEGER ncum, nd, nloc
    1098   INTEGER inb(nloc)
    1099   REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd)
    1100   REAL gz(nloc, nd), u(nloc, nd), v(nloc, nd)
    1101   REAL p(nloc, nd), ph(nloc, nd + 1), h(nloc, nd)
    1102   REAL lv(nloc, nd), ep(nloc, nd), sigp(nloc, nd), clw(nloc, nd)
    1103   REAL m(nloc, nd), ment(nloc, nd, nd), elij(nloc, nd, nd)
    1104 
    1105   ! outputs:
    1106   INTEGER iflag(nloc) ! also an input
    1107   REAL mp(nloc, nd), qp(nloc, nd), up(nloc, nd), vp(nloc, nd)
    1108   REAL water(nloc, nd), evap(nloc, nd), wt(nloc, nd)
    1109 
    1110   ! local variables:
    1111   INTEGER i, j, k, ij, num1
    1112   INTEGER jtt(nloc)
    1113   REAL awat, coeff, qsm, afac, sigt, b6, c6, revap
    1114   REAL dhdp, fac, qstm, rat
    1115   REAL wdtrain(nloc)
    1116   LOGICAL lwork(nloc)
    1117 
    1118   ! =====================================================================
    1119   ! --- PRECIPITATING DOWNDRAFT CALCULATION
    1120   ! =====================================================================
    1121 
    1122   ! Initializations:
    1123 
    1124   DO i = 1, ncum
    1125     DO k = 1, nl + 1
    1126       wt(i, k) = omtsnow
    1127       mp(i, k) = 0.0
    1128       evap(i, k) = 0.0
    1129       water(i, k) = 0.0
    1130     END DO
    1131   END DO
    1132 
    1133   DO i = 1, ncum
    1134     qp(i, 1) = q(i, 1)
    1135     up(i, 1) = u(i, 1)
    1136     vp(i, 1) = v(i, 1)
    1137   END DO
    1138 
    1139   DO k = 2, nl + 1
    1140     DO i = 1, ncum
    1141       qp(i, k) = q(i, k - 1)
    1142       up(i, k) = u(i, k - 1)
    1143       vp(i, k) = v(i, k - 1)
    1144     END DO
    1145   END DO
    1146 
    1147 
    1148   ! ***  Check whether ep(inb)=0, if so, skip precipitating    ***
    1149   ! ***             downdraft calculation                      ***
    1150 
    1151 
    1152   ! ***  Integrate liquid water equation to find condensed water   ***
    1153   ! ***                and condensed water flux                    ***
    1154 
    1155   DO i = 1, ncum
    1156     jtt(i) = 2
    1157     IF (ep(i, inb(i))<=0.0001) iflag(i) = 2
    1158     IF (iflag(i)==0) THEN
    1159       lwork(i) = .TRUE.
    1160     ELSE
    1161       lwork(i) = .FALSE.
    1162     END IF
    1163   END DO
    1164 
    1165   ! ***                    Begin downdraft loop                    ***
    1166 
    1167   CALL zilch(wdtrain, ncum)
    1168   DO i = nl + 1, 1, -1
    1169 
    1170     num1 = 0
    1171     DO ij = 1, ncum
    1172       IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1
    1173     END DO
    1174     IF (num1<=0) GO TO 899
    1175 
    1176 
    1177     ! ***        Calculate detrained precipitation             ***
    1178 
    1179     DO ij = 1, ncum
    1180       IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
    1181         wdtrain(ij) = g * ep(ij, i) * m(ij, i) * clw(ij, i)
    1182       END IF
    1183     END DO
    1184 
    1185     IF (i>1) THEN
    1186       DO j = 1, i - 1
    1187         DO ij = 1, ncum
    1188           IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
    1189             awat = elij(ij, j, i) - (1. - ep(ij, i)) * clw(ij, i)
    1190             awat = max(0.0, awat)
    1191             wdtrain(ij) = wdtrain(ij) + g * awat * ment(ij, j, i)
     971            IF (sij(ij, i, j)>0.0 .AND. sij(ij, i, j)<0.9) THEN
     972              qent(ij, i, j) = sij(ij, i, j) * q(ij, i) + (1. - sij(ij, i, j)) * qti
     973              uent(ij, i, j) = sij(ij, i, j) * u(ij, i) + &
     974                      (1. - sij(ij, i, j)) * u(ij, nk(ij))
     975              vent(ij, i, j) = sij(ij, i, j) * v(ij, i) + &
     976                      (1. - sij(ij, i, j)) * v(ij, nk(ij))
     977              elij(ij, i, j) = altem
     978              elij(ij, i, j) = max(0.0, elij(ij, i, j))
     979              ment(ij, i, j) = m(ij, i) / (1. - sij(ij, i, j))
     980              nent(ij, i) = nent(ij, i) + 1
     981            END IF
     982            sij(ij, i, j) = max(0.0, sij(ij, i, j))
     983            sij(ij, i, j) = min(1.0, sij(ij, i, j))
    1192984          END IF
    1193985        END DO
    1194986      END DO
    1195     END IF
    1196 
    1197     ! ***    Find rain water and evaporation using provisional   ***
    1198     ! ***              estimates of qp(i)and qp(i-1)             ***
    1199 
    1200 
    1201     ! ***  Value of terminal velocity and coeffecient of evaporation for snow
    1202     ! ***
    1203 
     987
     988      ! ***   If no air can entrain at level i assume that updraft detrains
     989      ! ***
     990      ! ***   at that level and calculate detrained air flux and properties
     991      ! ***
     992
     993      DO ij = 1, ncum
     994        IF ((i>=(icb(ij) + 1)) .AND. (i<=inb(ij)) .AND. (nent(ij, i)==0)) THEN
     995          ment(ij, i, i) = m(ij, i)
     996          qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i) * clw(ij, i)
     997          uent(ij, i, i) = u(ij, nk(ij))
     998          vent(ij, i, i) = v(ij, nk(ij))
     999          elij(ij, i, i) = clw(ij, i)
     1000          sij(ij, i, i) = 1.0
     1001        END IF
     1002      END DO
     1003    END DO
     1004
     1005    DO i = 1, ncum
     1006      sij(i, inb(i), inb(i)) = 1.0
     1007    END DO
     1008
     1009    ! =====================================================================
     1010    ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
     1011    ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
     1012    ! =====================================================================
     1013
     1014    CALL zilch(bsum, ncum * nlp)
    12041015    DO ij = 1, ncum
    1205       IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
    1206         coeff = coeffs
    1207         wt(ij, i) = omtsnow
    1208 
    1209         ! ***  Value of terminal velocity and coeffecient of evaporation for
    1210         ! rain   ***
    1211 
    1212         IF (t(ij, i)>273.0) THEN
    1213           coeff = coeffr
    1214           wt(ij, i) = omtrain
    1215         END IF
    1216         qsm = 0.5 * (q(ij, i) + qp(ij, i + 1))
    1217         afac = coeff * ph(ij, i) * (qs(ij, i) - qsm) / (1.0E4 + 2.0E3 * ph(ij, i) * qs(ij, i))
    1218         afac = max(afac, 0.0)
    1219         sigt = sigp(ij, i)
    1220         sigt = max(0.0, sigt)
    1221         sigt = min(1.0, sigt)
    1222         b6 = 100. * (ph(ij, i) - ph(ij, i + 1)) * sigt * afac / wt(ij, i)
    1223         c6 = (water(ij, i + 1) * wt(ij, i + 1) + wdtrain(ij) / sigd) / wt(ij, i)
    1224         revap = 0.5 * (-b6 + sqrt(b6 * b6 + 4. * c6))
    1225         evap(ij, i) = sigt * afac * revap
    1226         water(ij, i) = revap * revap
    1227 
    1228         ! ***  Calculate precipitating downdraft mass flux under     ***
    1229         ! ***              hydrostatic approximation                 ***
    1230 
    1231         IF (i>1) THEN
    1232           dhdp = (h(ij, i) - h(ij, i - 1)) / (p(ij, i - 1) - p(ij, i))
    1233           dhdp = max(dhdp, 10.0)
    1234           mp(ij, i) = 100. * ginv * lv(ij, i) * sigd * evap(ij, i) / dhdp
    1235           mp(ij, i) = max(mp(ij, i), 0.0)
    1236 
    1237           ! ***   Add small amount of inertia to downdraft              ***
    1238 
    1239           fac = 20.0 / (ph(ij, i - 1) - ph(ij, i))
    1240           mp(ij, i) = (fac * mp(ij, i + 1) + mp(ij, i)) / (1. + fac)
    1241 
    1242           ! ***      Force mp to decrease linearly to zero
    1243           ! ***
    1244           ! ***      between about 950 mb and the surface
    1245           ! ***
    1246 
    1247           IF (p(ij, i)>(0.949 * p(ij, 1))) THEN
    1248             jtt(ij) = max(jtt(ij), i)
    1249             mp(ij, i) = mp(ij, jtt(ij)) * (p(ij, 1) - p(ij, i)) / &
    1250                     (p(ij, 1) - p(ij, jtt(ij)))
    1251           END IF
    1252         END IF
    1253 
    1254         ! ***       Find mixing ratio of precipitating downdraft     ***
    1255 
    1256         IF (i/=inb(ij)) THEN
    1257           IF (i==1) THEN
    1258             qstm = qs(ij, 1)
    1259           ELSE
    1260             qstm = qs(ij, i - 1)
    1261           END IF
    1262           IF (mp(ij, i)>mp(ij, i + 1)) THEN
    1263             rat = mp(ij, i + 1) / mp(ij, i)
    1264             qp(ij, i) = qp(ij, i + 1) * rat + q(ij, i) * (1.0 - rat) + &
    1265                     100. * ginv * sigd * (ph(ij, i) - ph(ij, i + 1)) * (evap(ij, i) / mp(ij, i))
    1266             up(ij, i) = up(ij, i + 1) * rat + u(ij, i) * (1. - rat)
    1267             vp(ij, i) = vp(ij, i + 1) * rat + v(ij, i) * (1. - rat)
    1268           ELSE
    1269             IF (mp(ij, i + 1)>0.0) THEN
    1270               qp(ij, i) = (gz(ij, i + 1) - gz(ij, i) + qp(ij, i + 1) * (lv(ij, i + 1) + t(ij, &
    1271                       i + 1) * (cl - cpd)) + cpd * (t(ij, i + 1) - t(ij, &
    1272                       i))) / (lv(ij, i) + t(ij, i) * (cl - cpd))
    1273               up(ij, i) = up(ij, i + 1)
    1274               vp(ij, i) = vp(ij, i + 1)
     1016      lwork(ij) = .FALSE.
     1017    END DO
     1018    DO i = minorig + 1, nl
     1019
     1020      num1 = 0
     1021      DO ij = 1, ncum
     1022        IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij))) num1 = num1 + 1
     1023      END DO
     1024      IF (num1<=0) GO TO 789
     1025
     1026      DO ij = 1, ncum
     1027        IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij))) THEN
     1028          lwork(ij) = (nent(ij, i)/=0)
     1029          qp1 = q(ij, nk(ij)) - ep(ij, i) * clw(ij, i)
     1030          anum = h(ij, i) - hp(ij, i) - lv(ij, i) * (qp1 - qs(ij, i))
     1031          denom = h(ij, i) - hp(ij, i) + lv(ij, i) * (q(ij, i) - qp1)
     1032          IF (abs(denom)<0.01) denom = 0.01
     1033          scrit(ij) = anum / denom
     1034          alt = qp1 - qs(ij, i) + scrit(ij) * (q(ij, i) - qp1)
     1035          IF (scrit(ij)<0.0 .OR. alt<0.0) scrit(ij) = 1.0
     1036          asij(ij) = 0.0
     1037          smin(ij) = 1.0
     1038        END IF
     1039      END DO
     1040      DO j = minorig, nl
     1041
     1042        num2 = 0
     1043        DO ij = 1, ncum
     1044          IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij)) .AND. (j>=icb(&
     1045                  ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1
     1046        END DO
     1047        IF (num2<=0) GO TO 783
     1048
     1049        DO ij = 1, ncum
     1050          IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij)) .AND. (j>=icb(&
     1051                  ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
     1052            IF (sij(ij, i, j)>0.0 .AND. sij(ij, i, j)<0.9) THEN
     1053              IF (j>i) THEN
     1054                smid = min(sij(ij, i, j), scrit(ij))
     1055                sjmax = smid
     1056                sjmin = smid
     1057                IF (smid<smin(ij) .AND. sij(ij, i, j + 1)<smid) THEN
     1058                  smin(ij) = smid
     1059                  sjmax = min(sij(ij, i, j + 1), sij(ij, i, j), scrit(ij))
     1060                  sjmin = max(sij(ij, i, j - 1), sij(ij, i, j))
     1061                  sjmin = min(sjmin, scrit(ij))
     1062                END IF
     1063              ELSE
     1064                sjmax = max(sij(ij, i, j + 1), scrit(ij))
     1065                smid = max(sij(ij, i, j), scrit(ij))
     1066                sjmin = 0.0
     1067                IF (j>1) sjmin = sij(ij, i, j - 1)
     1068                sjmin = max(sjmin, scrit(ij))
     1069              END IF
     1070              delp = abs(sjmax - smid)
     1071              delm = abs(sjmin - smid)
     1072              asij(ij) = asij(ij) + (delp + delm) * (ph(ij, j) - ph(ij, j + 1))
     1073              ment(ij, i, j) = ment(ij, i, j) * (delp + delm) * (ph(ij, j) - ph(ij, j + 1))
    12751074            END IF
    12761075          END IF
    1277           qp(ij, i) = min(qp(ij, i), qstm)
    1278           qp(ij, i) = max(qp(ij, i), 0.0)
    1279         END IF
    1280       END IF
    1281     END DO
    1282   899 END DO
    1283 
    1284 END SUBROUTINE cv_unsat
    1285 
    1286 SUBROUTINE cv_yield(nloc, ncum, nd, nk, icb, inb, delt, t, q, u, v, gz, p, &
    1287         ph, h, hp, lv, cpn, ep, clw, frac, m, mp, qp, up, vp, wt, water, evap, &
    1288         ment, qent, uent, vent, nent, elij, tv, tvp, iflag, wd, qprime, tprime, &
    1289         precip, cbmf, ft, fq, fu, fv, ma, qcondc)
    1290   USE lmdz_cvthermo
    1291 
    1292   IMPLICIT NONE
    1293 
    1294   include "cvparam.h"
    1295 
    1296   ! inputs
    1297   INTEGER ncum, nd, nloc
    1298   INTEGER nk(nloc), icb(nloc), inb(nloc)
    1299   INTEGER nent(nloc, nd)
    1300   REAL delt
    1301   REAL t(nloc, nd), q(nloc, nd), u(nloc, nd), v(nloc, nd)
    1302   REAL gz(nloc, nd)
    1303   REAL p(nloc, nd), ph(nloc, nd + 1), h(nloc, nd)
    1304   REAL hp(nloc, nd), lv(nloc, nd)
    1305   REAL cpn(nloc, nd), ep(nloc, nd), clw(nloc, nd), frac(nloc)
    1306   REAL m(nloc, nd), mp(nloc, nd), qp(nloc, nd)
    1307   REAL up(nloc, nd), vp(nloc, nd)
    1308   REAL wt(nloc, nd), water(nloc, nd), evap(nloc, nd)
    1309   REAL ment(nloc, nd, nd), qent(nloc, nd, nd), elij(nloc, nd, nd)
    1310   REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
    1311   REAL tv(nloc, nd), tvp(nloc, nd)
    1312 
    1313   ! outputs
    1314   INTEGER iflag(nloc) ! also an input
    1315   REAL cbmf(nloc) ! also an input
    1316   REAL wd(nloc), tprime(nloc), qprime(nloc)
    1317   REAL precip(nloc)
    1318   REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
    1319   REAL ma(nloc, nd)
    1320   REAL qcondc(nloc, nd)
    1321 
    1322   ! local variables
    1323   INTEGER i, j, ij, k, num1
    1324   REAL dpinv, cpinv, awat, fqold, ftold, fuold, fvold, delti
    1325   REAL work(nloc), am(nloc), amp1(nloc), ad(nloc)
    1326   REAL ents(nloc), uav(nloc), vav(nloc), lvcp(nloc, nd)
    1327   REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
    1328   REAL siga(nloc, nd), ax(nloc, nd), mac(nloc, nd) ! cld
    1329 
    1330 
    1331   ! -- initializations:
    1332 
    1333   delti = 1.0 / delt
    1334 
    1335   DO i = 1, ncum
    1336     precip(i) = 0.0
    1337     wd(i) = 0.0
    1338     tprime(i) = 0.0
    1339     qprime(i) = 0.0
    1340     DO k = 1, nl + 1
    1341       ft(i, k) = 0.0
    1342       fu(i, k) = 0.0
    1343       fv(i, k) = 0.0
    1344       fq(i, k) = 0.0
    1345       lvcp(i, k) = lv(i, k) / cpn(i, k)
    1346       qcondc(i, k) = 0.0 ! cld
    1347       qcond(i, k) = 0.0 ! cld
    1348       nqcond(i, k) = 0.0 ! cld
    1349     END DO
    1350   END DO
    1351 
    1352 
    1353   ! ***  Calculate surface precipitation in mm/day     ***
    1354 
    1355   DO i = 1, ncum
    1356     IF (iflag(i)<=1) THEN
    1357       ! c            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
    1358       ! c     &                /(rowl*g)
    1359       ! c            precip(i)=precip(i)*delt/86400.
    1360       precip(i) = wt(i, 1) * sigd * water(i, 1) * 86400 / g
    1361     END IF
    1362   END DO
    1363 
    1364 
    1365   ! ***  Calculate downdraft velocity scale and surface temperature and  ***
    1366   ! ***                    water vapor fluctuations                      ***
    1367 
    1368   DO i = 1, ncum
    1369     wd(i) = betad * abs(mp(i, icb(i))) * 0.01 * rrd * t(i, icb(i)) / (sigd * p(i, icb(i)))
    1370     qprime(i) = 0.5 * (qp(i, 1) - q(i, 1))
    1371     tprime(i) = lv0 * qprime(i) / cpd
    1372   END DO
    1373 
    1374   ! ***  Calculate tendencies of lowest level potential temperature  ***
    1375   ! ***                      and mixing ratio                        ***
    1376 
    1377   DO i = 1, ncum
    1378     work(i) = 0.01 / (ph(i, 1) - ph(i, 2))
    1379     am(i) = 0.0
    1380   END DO
    1381   DO k = 2, nl
    1382     DO i = 1, ncum
    1383       IF ((nk(i)==1) .AND. (k<=inb(i)) .AND. (nk(i)==1)) THEN
    1384         am(i) = am(i) + m(i, k)
    1385       END IF
    1386     END DO
    1387   END DO
    1388   DO i = 1, ncum
    1389     IF ((g * work(i) * am(i))>=delti) iflag(i) = 1
    1390     ft(i, 1) = ft(i, 1) + g * work(i) * am(i) * (t(i, 2) - t(i, 1) + (gz(i, 2) - gz(i, &
    1391             1)) / cpn(i, 1))
    1392     ft(i, 1) = ft(i, 1) - lvcp(i, 1) * sigd * evap(i, 1)
    1393     ft(i, 1) = ft(i, 1) + sigd * wt(i, 2) * (cl - cpd) * water(i, 2) * (t(i, 2) - t(i, 1)) * &
    1394             work(i) / cpn(i, 1)
    1395     fq(i, 1) = fq(i, 1) + g * mp(i, 2) * (qp(i, 2) - q(i, 1)) * work(i) + &
    1396             sigd * evap(i, 1)
    1397     fq(i, 1) = fq(i, 1) + g * am(i) * (q(i, 2) - q(i, 1)) * work(i)
    1398     fu(i, 1) = fu(i, 1) + g * work(i) * (mp(i, 2) * (up(i, 2) - u(i, 1)) + am(i) * (u(i, &
    1399             2) - u(i, 1)))
    1400     fv(i, 1) = fv(i, 1) + g * work(i) * (mp(i, 2) * (vp(i, 2) - v(i, 1)) + am(i) * (v(i, &
    1401             2) - v(i, 1)))
    1402   END DO
    1403   DO j = 2, nl
    1404     DO i = 1, ncum
    1405       IF (j<=inb(i)) THEN
    1406         fq(i, 1) = fq(i, 1) + g * work(i) * ment(i, j, 1) * (qent(i, j, 1) - q(i, 1))
    1407         fu(i, 1) = fu(i, 1) + g * work(i) * ment(i, j, 1) * (uent(i, j, 1) - u(i, 1))
    1408         fv(i, 1) = fv(i, 1) + g * work(i) * ment(i, j, 1) * (vent(i, j, 1) - v(i, 1))
    1409       END IF
    1410     END DO
    1411   END DO
    1412 
    1413   ! ***  Calculate tendencies of potential temperature and mixing ratio  ***
    1414   ! ***               at levels above the lowest level                   ***
    1415 
    1416   ! ***  First find the net saturated updraft and downdraft mass fluxes  ***
    1417   ! ***                      through each level                          ***
    1418 
    1419   DO i = 2, nl + 1
    1420 
    1421     num1 = 0
    1422     DO ij = 1, ncum
    1423       IF (i<=inb(ij)) num1 = num1 + 1
    1424     END DO
    1425     IF (num1<=0) GO TO 1500
    1426 
    1427     CALL zilch(amp1, ncum)
    1428     CALL zilch(ad, ncum)
    1429 
    1430     DO k = i + 1, nl + 1
     1076        END DO
     1077      783 END DO
    14311078      DO ij = 1, ncum
    1432         IF ((i>=nk(ij)) .AND. (i<=inb(ij)) .AND. (k<=(inb(ij) + 1))) THEN
    1433           amp1(ij) = amp1(ij) + m(ij, k)
    1434         END IF
    1435       END DO
    1436     END DO
    1437 
    1438     DO k = 1, i
    1439       DO j = i + 1, nl + 1
     1079        IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij)) .AND. lwork(ij)) THEN
     1080          asij(ij) = max(1.0E-21, asij(ij))
     1081          asij(ij) = 1.0 / asij(ij)
     1082          bsum(ij, i) = 0.0
     1083        END IF
     1084      END DO
     1085      DO j = minorig, nl + 1
    14401086        DO ij = 1, ncum
    1441           IF ((j<=(inb(ij) + 1)) .AND. (i<=inb(ij))) THEN
    1442             amp1(ij) = amp1(ij) + ment(ij, k, j)
     1087          IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij)) .AND. (j>=icb(&
     1088                  ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
     1089            ment(ij, i, j) = ment(ij, i, j) * asij(ij)
     1090            bsum(ij, i) = bsum(ij, i) + ment(ij, i, j)
    14431091          END IF
    14441092        END DO
    14451093      END DO
    1446     END DO
    1447     DO k = 1, i - 1
    1448       DO j = i, nl + 1
     1094      DO ij = 1, ncum
     1095        IF ((i>=icb(ij) + 1) .AND. (i<=inb(ij)) .AND. (bsum(ij, &
     1096                i)<1.0E-18) .AND. lwork(ij)) THEN
     1097          nent(ij, i) = 0
     1098          ment(ij, i, i) = m(ij, i)
     1099          qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i) * clw(ij, i)
     1100          uent(ij, i, i) = u(ij, nk(ij))
     1101          vent(ij, i, i) = v(ij, nk(ij))
     1102          elij(ij, i, i) = clw(ij, i)
     1103          sij(ij, i, i) = 1.0
     1104        END IF
     1105      END DO
     1106    789 END DO
     1107
     1108  END SUBROUTINE cv_mixing
     1109
     1110  SUBROUTINE cv_unsat(nloc, ncum, nd, inb, t, q, qs, gz, u, v, p, ph, h, lv, &
     1111          ep, sigp, clw, m, ment, elij, iflag, mp, qp, up, vp, wt, water, evap)
     1112    USE lmdz_cvthermo
     1113
     1114    IMPLICIT NONE
     1115
     1116
     1117    ! inputs:
     1118    INTEGER ncum, nd, nloc
     1119    INTEGER inb(nloc)
     1120    REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd)
     1121    REAL gz(nloc, nd), u(nloc, nd), v(nloc, nd)
     1122    REAL p(nloc, nd), ph(nloc, nd + 1), h(nloc, nd)
     1123    REAL lv(nloc, nd), ep(nloc, nd), sigp(nloc, nd), clw(nloc, nd)
     1124    REAL m(nloc, nd), ment(nloc, nd, nd), elij(nloc, nd, nd)
     1125
     1126    ! outputs:
     1127    INTEGER iflag(nloc) ! also an input
     1128    REAL mp(nloc, nd), qp(nloc, nd), up(nloc, nd), vp(nloc, nd)
     1129    REAL water(nloc, nd), evap(nloc, nd), wt(nloc, nd)
     1130
     1131    ! local variables:
     1132    INTEGER i, j, k, ij, num1
     1133    INTEGER jtt(nloc)
     1134    REAL awat, coeff, qsm, afac, sigt, b6, c6, revap
     1135    REAL dhdp, fac, qstm, rat
     1136    REAL wdtrain(nloc)
     1137    LOGICAL lwork(nloc)
     1138
     1139    ! =====================================================================
     1140    ! --- PRECIPITATING DOWNDRAFT CALCULATION
     1141    ! =====================================================================
     1142
     1143    ! Initializations:
     1144
     1145    DO i = 1, ncum
     1146      DO k = 1, nl + 1
     1147        wt(i, k) = omtsnow
     1148        mp(i, k) = 0.0
     1149        evap(i, k) = 0.0
     1150        water(i, k) = 0.0
     1151      END DO
     1152    END DO
     1153
     1154    DO i = 1, ncum
     1155      qp(i, 1) = q(i, 1)
     1156      up(i, 1) = u(i, 1)
     1157      vp(i, 1) = v(i, 1)
     1158    END DO
     1159
     1160    DO k = 2, nl + 1
     1161      DO i = 1, ncum
     1162        qp(i, k) = q(i, k - 1)
     1163        up(i, k) = u(i, k - 1)
     1164        vp(i, k) = v(i, k - 1)
     1165      END DO
     1166    END DO
     1167
     1168
     1169    ! ***  Check whether ep(inb)=0, if so, skip precipitating    ***
     1170    ! ***             downdraft calculation                      ***
     1171
     1172
     1173    ! ***  Integrate liquid water equation to find condensed water   ***
     1174    ! ***                and condensed water flux                    ***
     1175
     1176    DO i = 1, ncum
     1177      jtt(i) = 2
     1178      IF (ep(i, inb(i))<=0.0001) iflag(i) = 2
     1179      IF (iflag(i)==0) THEN
     1180        lwork(i) = .TRUE.
     1181      ELSE
     1182        lwork(i) = .FALSE.
     1183      END IF
     1184    END DO
     1185
     1186    ! ***                    Begin downdraft loop                    ***
     1187
     1188    CALL zilch(wdtrain, ncum)
     1189    DO i = nl + 1, 1, -1
     1190
     1191      num1 = 0
     1192      DO ij = 1, ncum
     1193        IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1
     1194      END DO
     1195      IF (num1<=0) GO TO 899
     1196
     1197
     1198      ! ***        Calculate detrained precipitation             ***
     1199
     1200      DO ij = 1, ncum
     1201        IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
     1202          wdtrain(ij) = g * ep(ij, i) * m(ij, i) * clw(ij, i)
     1203        END IF
     1204      END DO
     1205
     1206      IF (i>1) THEN
     1207        DO j = 1, i - 1
     1208          DO ij = 1, ncum
     1209            IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
     1210              awat = elij(ij, j, i) - (1. - ep(ij, i)) * clw(ij, i)
     1211              awat = max(0.0, awat)
     1212              wdtrain(ij) = wdtrain(ij) + g * awat * ment(ij, j, i)
     1213            END IF
     1214          END DO
     1215        END DO
     1216      END IF
     1217
     1218      ! ***    Find rain water and evaporation using provisional   ***
     1219      ! ***              estimates of qp(i)and qp(i-1)             ***
     1220
     1221
     1222      ! ***  Value of terminal velocity and coeffecient of evaporation for snow
     1223      ! ***
     1224
     1225      DO ij = 1, ncum
     1226        IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
     1227          coeff = coeffs
     1228          wt(ij, i) = omtsnow
     1229
     1230          ! ***  Value of terminal velocity and coeffecient of evaporation for
     1231          ! rain   ***
     1232
     1233          IF (t(ij, i)>273.0) THEN
     1234            coeff = coeffr
     1235            wt(ij, i) = omtrain
     1236          END IF
     1237          qsm = 0.5 * (q(ij, i) + qp(ij, i + 1))
     1238          afac = coeff * ph(ij, i) * (qs(ij, i) - qsm) / (1.0E4 + 2.0E3 * ph(ij, i) * qs(ij, i))
     1239          afac = max(afac, 0.0)
     1240          sigt = sigp(ij, i)
     1241          sigt = max(0.0, sigt)
     1242          sigt = min(1.0, sigt)
     1243          b6 = 100. * (ph(ij, i) - ph(ij, i + 1)) * sigt * afac / wt(ij, i)
     1244          c6 = (water(ij, i + 1) * wt(ij, i + 1) + wdtrain(ij) / sigd) / wt(ij, i)
     1245          revap = 0.5 * (-b6 + sqrt(b6 * b6 + 4. * c6))
     1246          evap(ij, i) = sigt * afac * revap
     1247          water(ij, i) = revap * revap
     1248
     1249          ! ***  Calculate precipitating downdraft mass flux under     ***
     1250          ! ***              hydrostatic approximation                 ***
     1251
     1252          IF (i>1) THEN
     1253            dhdp = (h(ij, i) - h(ij, i - 1)) / (p(ij, i - 1) - p(ij, i))
     1254            dhdp = max(dhdp, 10.0)
     1255            mp(ij, i) = 100. * ginv * lv(ij, i) * sigd * evap(ij, i) / dhdp
     1256            mp(ij, i) = max(mp(ij, i), 0.0)
     1257
     1258            ! ***   Add small amount of inertia to downdraft              ***
     1259
     1260            fac = 20.0 / (ph(ij, i - 1) - ph(ij, i))
     1261            mp(ij, i) = (fac * mp(ij, i + 1) + mp(ij, i)) / (1. + fac)
     1262
     1263            ! ***      Force mp to decrease linearly to zero
     1264            ! ***
     1265            ! ***      between about 950 mb and the surface
     1266            ! ***
     1267
     1268            IF (p(ij, i)>(0.949 * p(ij, 1))) THEN
     1269              jtt(ij) = max(jtt(ij), i)
     1270              mp(ij, i) = mp(ij, jtt(ij)) * (p(ij, 1) - p(ij, i)) / &
     1271                      (p(ij, 1) - p(ij, jtt(ij)))
     1272            END IF
     1273          END IF
     1274
     1275          ! ***       Find mixing ratio of precipitating downdraft     ***
     1276
     1277          IF (i/=inb(ij)) THEN
     1278            IF (i==1) THEN
     1279              qstm = qs(ij, 1)
     1280            ELSE
     1281              qstm = qs(ij, i - 1)
     1282            END IF
     1283            IF (mp(ij, i)>mp(ij, i + 1)) THEN
     1284              rat = mp(ij, i + 1) / mp(ij, i)
     1285              qp(ij, i) = qp(ij, i + 1) * rat + q(ij, i) * (1.0 - rat) + &
     1286                      100. * ginv * sigd * (ph(ij, i) - ph(ij, i + 1)) * (evap(ij, i) / mp(ij, i))
     1287              up(ij, i) = up(ij, i + 1) * rat + u(ij, i) * (1. - rat)
     1288              vp(ij, i) = vp(ij, i + 1) * rat + v(ij, i) * (1. - rat)
     1289            ELSE
     1290              IF (mp(ij, i + 1)>0.0) THEN
     1291                qp(ij, i) = (gz(ij, i + 1) - gz(ij, i) + qp(ij, i + 1) * (lv(ij, i + 1) + t(ij, &
     1292                        i + 1) * (cl - cpd)) + cpd * (t(ij, i + 1) - t(ij, &
     1293                        i))) / (lv(ij, i) + t(ij, i) * (cl - cpd))
     1294                up(ij, i) = up(ij, i + 1)
     1295                vp(ij, i) = vp(ij, i + 1)
     1296              END IF
     1297            END IF
     1298            qp(ij, i) = min(qp(ij, i), qstm)
     1299            qp(ij, i) = max(qp(ij, i), 0.0)
     1300          END IF
     1301        END IF
     1302      END DO
     1303    899 END DO
     1304
     1305  END SUBROUTINE cv_unsat
     1306
     1307  SUBROUTINE cv_yield(nloc, ncum, nd, nk, icb, inb, delt, t, q, u, v, gz, p, &
     1308          ph, h, hp, lv, cpn, ep, clw, frac, m, mp, qp, up, vp, wt, water, evap, &
     1309          ment, qent, uent, vent, nent, elij, tv, tvp, iflag, wd, qprime, tprime, &
     1310          precip, cbmf, ft, fq, fu, fv, ma, qcondc)
     1311    USE lmdz_cvthermo
     1312
     1313    IMPLICIT NONE
     1314
     1315
     1316    ! inputs
     1317    INTEGER ncum, nd, nloc
     1318    INTEGER nk(nloc), icb(nloc), inb(nloc)
     1319    INTEGER nent(nloc, nd)
     1320    REAL delt
     1321    REAL t(nloc, nd), q(nloc, nd), u(nloc, nd), v(nloc, nd)
     1322    REAL gz(nloc, nd)
     1323    REAL p(nloc, nd), ph(nloc, nd + 1), h(nloc, nd)
     1324    REAL hp(nloc, nd), lv(nloc, nd)
     1325    REAL cpn(nloc, nd), ep(nloc, nd), clw(nloc, nd), frac(nloc)
     1326    REAL m(nloc, nd), mp(nloc, nd), qp(nloc, nd)
     1327    REAL up(nloc, nd), vp(nloc, nd)
     1328    REAL wt(nloc, nd), water(nloc, nd), evap(nloc, nd)
     1329    REAL ment(nloc, nd, nd), qent(nloc, nd, nd), elij(nloc, nd, nd)
     1330    REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
     1331    REAL tv(nloc, nd), tvp(nloc, nd)
     1332
     1333    ! outputs
     1334    INTEGER iflag(nloc) ! also an input
     1335    REAL cbmf(nloc) ! also an input
     1336    REAL wd(nloc), tprime(nloc), qprime(nloc)
     1337    REAL precip(nloc)
     1338    REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
     1339    REAL ma(nloc, nd)
     1340    REAL qcondc(nloc, nd)
     1341
     1342    ! local variables
     1343    INTEGER i, j, ij, k, num1
     1344    REAL dpinv, cpinv, awat, fqold, ftold, fuold, fvold, delti
     1345    REAL work(nloc), am(nloc), amp1(nloc), ad(nloc)
     1346    REAL ents(nloc), uav(nloc), vav(nloc), lvcp(nloc, nd)
     1347    REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
     1348    REAL siga(nloc, nd), ax(nloc, nd), mac(nloc, nd) ! cld
     1349
     1350
     1351    ! -- initializations:
     1352
     1353    delti = 1.0 / delt
     1354
     1355    DO i = 1, ncum
     1356      precip(i) = 0.0
     1357      wd(i) = 0.0
     1358      tprime(i) = 0.0
     1359      qprime(i) = 0.0
     1360      DO k = 1, nl + 1
     1361        ft(i, k) = 0.0
     1362        fu(i, k) = 0.0
     1363        fv(i, k) = 0.0
     1364        fq(i, k) = 0.0
     1365        lvcp(i, k) = lv(i, k) / cpn(i, k)
     1366        qcondc(i, k) = 0.0 ! cld
     1367        qcond(i, k) = 0.0 ! cld
     1368        nqcond(i, k) = 0.0 ! cld
     1369      END DO
     1370    END DO
     1371
     1372
     1373    ! ***  Calculate surface precipitation in mm/day     ***
     1374
     1375    DO i = 1, ncum
     1376      IF (iflag(i)<=1) THEN
     1377        ! c            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
     1378        ! c     &                /(rowl*g)
     1379        ! c            precip(i)=precip(i)*delt/86400.
     1380        precip(i) = wt(i, 1) * sigd * water(i, 1) * 86400 / g
     1381      END IF
     1382    END DO
     1383
     1384
     1385    ! ***  Calculate downdraft velocity scale and surface temperature and  ***
     1386    ! ***                    water vapor fluctuations                      ***
     1387
     1388    DO i = 1, ncum
     1389      wd(i) = betad * abs(mp(i, icb(i))) * 0.01 * rrd * t(i, icb(i)) / (sigd * p(i, icb(i)))
     1390      qprime(i) = 0.5 * (qp(i, 1) - q(i, 1))
     1391      tprime(i) = lv0 * qprime(i) / cpd
     1392    END DO
     1393
     1394    ! ***  Calculate tendencies of lowest level potential temperature  ***
     1395    ! ***                      and mixing ratio                        ***
     1396
     1397    DO i = 1, ncum
     1398      work(i) = 0.01 / (ph(i, 1) - ph(i, 2))
     1399      am(i) = 0.0
     1400    END DO
     1401    DO k = 2, nl
     1402      DO i = 1, ncum
     1403        IF ((nk(i)==1) .AND. (k<=inb(i)) .AND. (nk(i)==1)) THEN
     1404          am(i) = am(i) + m(i, k)
     1405        END IF
     1406      END DO
     1407    END DO
     1408    DO i = 1, ncum
     1409      IF ((g * work(i) * am(i))>=delti) iflag(i) = 1
     1410      ft(i, 1) = ft(i, 1) + g * work(i) * am(i) * (t(i, 2) - t(i, 1) + (gz(i, 2) - gz(i, &
     1411              1)) / cpn(i, 1))
     1412      ft(i, 1) = ft(i, 1) - lvcp(i, 1) * sigd * evap(i, 1)
     1413      ft(i, 1) = ft(i, 1) + sigd * wt(i, 2) * (cl - cpd) * water(i, 2) * (t(i, 2) - t(i, 1)) * &
     1414              work(i) / cpn(i, 1)
     1415      fq(i, 1) = fq(i, 1) + g * mp(i, 2) * (qp(i, 2) - q(i, 1)) * work(i) + &
     1416              sigd * evap(i, 1)
     1417      fq(i, 1) = fq(i, 1) + g * am(i) * (q(i, 2) - q(i, 1)) * work(i)
     1418      fu(i, 1) = fu(i, 1) + g * work(i) * (mp(i, 2) * (up(i, 2) - u(i, 1)) + am(i) * (u(i, &
     1419              2) - u(i, 1)))
     1420      fv(i, 1) = fv(i, 1) + g * work(i) * (mp(i, 2) * (vp(i, 2) - v(i, 1)) + am(i) * (v(i, &
     1421              2) - v(i, 1)))
     1422    END DO
     1423    DO j = 2, nl
     1424      DO i = 1, ncum
     1425        IF (j<=inb(i)) THEN
     1426          fq(i, 1) = fq(i, 1) + g * work(i) * ment(i, j, 1) * (qent(i, j, 1) - q(i, 1))
     1427          fu(i, 1) = fu(i, 1) + g * work(i) * ment(i, j, 1) * (uent(i, j, 1) - u(i, 1))
     1428          fv(i, 1) = fv(i, 1) + g * work(i) * ment(i, j, 1) * (vent(i, j, 1) - v(i, 1))
     1429        END IF
     1430      END DO
     1431    END DO
     1432
     1433    ! ***  Calculate tendencies of potential temperature and mixing ratio  ***
     1434    ! ***               at levels above the lowest level                   ***
     1435
     1436    ! ***  First find the net saturated updraft and downdraft mass fluxes  ***
     1437    ! ***                      through each level                          ***
     1438
     1439    DO i = 2, nl + 1
     1440
     1441      num1 = 0
     1442      DO ij = 1, ncum
     1443        IF (i<=inb(ij)) num1 = num1 + 1
     1444      END DO
     1445      IF (num1<=0) GO TO 1500
     1446
     1447      CALL zilch(amp1, ncum)
     1448      CALL zilch(ad, ncum)
     1449
     1450      DO k = i + 1, nl + 1
    14491451        DO ij = 1, ncum
    1450           IF ((i<=inb(ij)) .AND. (j<=inb(ij))) THEN
    1451             ad(ij) = ad(ij) + ment(ij, j, k)
     1452          IF ((i>=nk(ij)) .AND. (i<=inb(ij)) .AND. (k<=(inb(ij) + 1))) THEN
     1453            amp1(ij) = amp1(ij) + m(ij, k)
    14521454          END IF
    14531455        END DO
    14541456      END DO
    1455     END DO
    1456 
    1457     DO ij = 1, ncum
    1458       IF (i<=inb(ij)) THEN
    1459         dpinv = 0.01 / (ph(ij, i) - ph(ij, i + 1))
    1460         cpinv = 1.0 / cpn(ij, i)
    1461 
    1462         ft(ij, i) = ft(ij, i) + g * dpinv * (amp1(ij) * (t(ij, i + 1) - t(ij, &
    1463                 i) + (gz(ij, i + 1) - gz(ij, i)) * cpinv) - ad(ij) * (t(ij, i) - t(ij, &
    1464                 i - 1) + (gz(ij, i) - gz(ij, i - 1)) * cpinv)) - sigd * lvcp(ij, i) * evap(ij, i)
    1465         ft(ij, i) = ft(ij, i) + g * dpinv * ment(ij, i, i) * (hp(ij, i) - h(ij, i) + t(ij &
    1466                 , i) * (cpv - cpd) * (q(ij, i) - qent(ij, i, i))) * cpinv
    1467         ft(ij, i) = ft(ij, i) + sigd * wt(ij, i + 1) * (cl - cpd) * water(ij, i + 1) * (t(&
    1468                 ij, i + 1) - t(ij, i)) * dpinv * cpinv
    1469         fq(ij, i) = fq(ij, i) + g * dpinv * (amp1(ij) * (q(ij, i + 1) - q(ij, &
    1470                 i)) - ad(ij) * (q(ij, i) - q(ij, i - 1)))
    1471         fu(ij, i) = fu(ij, i) + g * dpinv * (amp1(ij) * (u(ij, i + 1) - u(ij, &
    1472                 i)) - ad(ij) * (u(ij, i) - u(ij, i - 1)))
    1473         fv(ij, i) = fv(ij, i) + g * dpinv * (amp1(ij) * (v(ij, i + 1) - v(ij, &
    1474                 i)) - ad(ij) * (v(ij, i) - v(ij, i - 1)))
    1475       END IF
    1476     END DO
    1477     DO k = 1, i - 1
     1457
     1458      DO k = 1, i
     1459        DO j = i + 1, nl + 1
     1460          DO ij = 1, ncum
     1461            IF ((j<=(inb(ij) + 1)) .AND. (i<=inb(ij))) THEN
     1462              amp1(ij) = amp1(ij) + ment(ij, k, j)
     1463            END IF
     1464          END DO
     1465        END DO
     1466      END DO
     1467      DO k = 1, i - 1
     1468        DO j = i, nl + 1
     1469          DO ij = 1, ncum
     1470            IF ((i<=inb(ij)) .AND. (j<=inb(ij))) THEN
     1471              ad(ij) = ad(ij) + ment(ij, j, k)
     1472            END IF
     1473          END DO
     1474        END DO
     1475      END DO
     1476
    14781477      DO ij = 1, ncum
    14791478        IF (i<=inb(ij)) THEN
    1480           awat = elij(ij, k, i) - (1. - ep(ij, i)) * clw(ij, i)
    1481           awat = max(awat, 0.0)
    1482           fq(ij, i) = fq(ij, i) + g * dpinv * ment(ij, k, i) * (qent(ij, k, i) - awat - q &
    1483                   (ij, i))
    1484           fu(ij, i) = fu(ij, i) + g * dpinv * ment(ij, k, i) * (uent(ij, k, i) - u(ij, i &
    1485                   ))
    1486           fv(ij, i) = fv(ij, i) + g * dpinv * ment(ij, k, i) * (vent(ij, k, i) - v(ij, i &
    1487                   ))
    1488           ! (saturated updrafts resulting from mixing)               ! cld
    1489           qcond(ij, i) = qcond(ij, i) + (elij(ij, k, i) - awat) ! cld
    1490           nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
    1491         END IF
    1492       END DO
    1493     END DO
    1494     DO k = i, nl + 1
     1479          dpinv = 0.01 / (ph(ij, i) - ph(ij, i + 1))
     1480          cpinv = 1.0 / cpn(ij, i)
     1481
     1482          ft(ij, i) = ft(ij, i) + g * dpinv * (amp1(ij) * (t(ij, i + 1) - t(ij, &
     1483                  i) + (gz(ij, i + 1) - gz(ij, i)) * cpinv) - ad(ij) * (t(ij, i) - t(ij, &
     1484                  i - 1) + (gz(ij, i) - gz(ij, i - 1)) * cpinv)) - sigd * lvcp(ij, i) * evap(ij, i)
     1485          ft(ij, i) = ft(ij, i) + g * dpinv * ment(ij, i, i) * (hp(ij, i) - h(ij, i) + t(ij &
     1486                  , i) * (cpv - cpd) * (q(ij, i) - qent(ij, i, i))) * cpinv
     1487          ft(ij, i) = ft(ij, i) + sigd * wt(ij, i + 1) * (cl - cpd) * water(ij, i + 1) * (t(&
     1488                  ij, i + 1) - t(ij, i)) * dpinv * cpinv
     1489          fq(ij, i) = fq(ij, i) + g * dpinv * (amp1(ij) * (q(ij, i + 1) - q(ij, &
     1490                  i)) - ad(ij) * (q(ij, i) - q(ij, i - 1)))
     1491          fu(ij, i) = fu(ij, i) + g * dpinv * (amp1(ij) * (u(ij, i + 1) - u(ij, &
     1492                  i)) - ad(ij) * (u(ij, i) - u(ij, i - 1)))
     1493          fv(ij, i) = fv(ij, i) + g * dpinv * (amp1(ij) * (v(ij, i + 1) - v(ij, &
     1494                  i)) - ad(ij) * (v(ij, i) - v(ij, i - 1)))
     1495        END IF
     1496      END DO
     1497      DO k = 1, i - 1
     1498        DO ij = 1, ncum
     1499          IF (i<=inb(ij)) THEN
     1500            awat = elij(ij, k, i) - (1. - ep(ij, i)) * clw(ij, i)
     1501            awat = max(awat, 0.0)
     1502            fq(ij, i) = fq(ij, i) + g * dpinv * ment(ij, k, i) * (qent(ij, k, i) - awat - q &
     1503                    (ij, i))
     1504            fu(ij, i) = fu(ij, i) + g * dpinv * ment(ij, k, i) * (uent(ij, k, i) - u(ij, i &
     1505                    ))
     1506            fv(ij, i) = fv(ij, i) + g * dpinv * ment(ij, k, i) * (vent(ij, k, i) - v(ij, i &
     1507                    ))
     1508            ! (saturated updrafts resulting from mixing)               ! cld
     1509            qcond(ij, i) = qcond(ij, i) + (elij(ij, k, i) - awat) ! cld
     1510            nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
     1511          END IF
     1512        END DO
     1513      END DO
     1514      DO k = i, nl + 1
     1515        DO ij = 1, ncum
     1516          IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN
     1517            fq(ij, i) = fq(ij, i) + g * dpinv * ment(ij, k, i) * (qent(ij, k, i) - q(ij, i &
     1518                    ))
     1519            fu(ij, i) = fu(ij, i) + g * dpinv * ment(ij, k, i) * (uent(ij, k, i) - u(ij, i &
     1520                    ))
     1521            fv(ij, i) = fv(ij, i) + g * dpinv * ment(ij, k, i) * (vent(ij, k, i) - v(ij, i &
     1522                    ))
     1523          END IF
     1524        END DO
     1525      END DO
    14951526      DO ij = 1, ncum
    1496         IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN
    1497           fq(ij, i) = fq(ij, i) + g * dpinv * ment(ij, k, i) * (qent(ij, k, i) - q(ij, i &
    1498                   ))
    1499           fu(ij, i) = fu(ij, i) + g * dpinv * ment(ij, k, i) * (uent(ij, k, i) - u(ij, i &
    1500                   ))
    1501           fv(ij, i) = fv(ij, i) + g * dpinv * ment(ij, k, i) * (vent(ij, k, i) - v(ij, i &
    1502                   ))
    1503         END IF
    1504       END DO
    1505     END DO
     1527        IF (i<=inb(ij)) THEN
     1528          fq(ij, i) = fq(ij, i) + sigd * evap(ij, i) + g * (mp(ij, i + 1) * (qp(ij, &
     1529                  i + 1) - q(ij, i)) - mp(ij, i) * (qp(ij, i) - q(ij, i - 1))) * dpinv
     1530          fu(ij, i) = fu(ij, i) + g * (mp(ij, i + 1) * (up(ij, i + 1) - u(ij, &
     1531                  i)) - mp(ij, i) * (up(ij, i) - u(ij, i - 1))) * dpinv
     1532          fv(ij, i) = fv(ij, i) + g * (mp(ij, i + 1) * (vp(ij, i + 1) - v(ij, &
     1533                  i)) - mp(ij, i) * (vp(ij, i) - v(ij, i - 1))) * dpinv
     1534          ! (saturated downdrafts resulting from mixing)               ! cld
     1535          DO k = i + 1, inb(ij) ! cld
     1536            qcond(ij, i) = qcond(ij, i) + elij(ij, k, i) ! cld
     1537            nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
     1538          END DO ! cld
     1539          ! (particular case: no detraining level is found)            ! cld
     1540          IF (nent(ij, i)==0) THEN ! cld
     1541            qcond(ij, i) = qcond(ij, i) + (1. - ep(ij, i)) * clw(ij, i) ! cld
     1542            nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
     1543          END IF ! cld
     1544          IF (nqcond(ij, i)/=0.) THEN ! cld
     1545            qcond(ij, i) = qcond(ij, i) / nqcond(ij, i) ! cld
     1546          END IF ! cld
     1547        END IF
     1548      END DO
     1549    1500 END DO
     1550
     1551    ! *** Adjust tendencies at top of convection layer to reflect  ***
     1552    ! ***       actual position of the level zero cape             ***
     1553
    15061554    DO ij = 1, ncum
    1507       IF (i<=inb(ij)) THEN
    1508         fq(ij, i) = fq(ij, i) + sigd * evap(ij, i) + g * (mp(ij, i + 1) * (qp(ij, &
    1509                 i + 1) - q(ij, i)) - mp(ij, i) * (qp(ij, i) - q(ij, i - 1))) * dpinv
    1510         fu(ij, i) = fu(ij, i) + g * (mp(ij, i + 1) * (up(ij, i + 1) - u(ij, &
    1511                 i)) - mp(ij, i) * (up(ij, i) - u(ij, i - 1))) * dpinv
    1512         fv(ij, i) = fv(ij, i) + g * (mp(ij, i + 1) * (vp(ij, i + 1) - v(ij, &
    1513                 i)) - mp(ij, i) * (vp(ij, i) - v(ij, i - 1))) * dpinv
    1514         ! (saturated downdrafts resulting from mixing)               ! cld
    1515         DO k = i + 1, inb(ij) ! cld
    1516           qcond(ij, i) = qcond(ij, i) + elij(ij, k, i) ! cld
    1517           nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
     1555      fqold = fq(ij, inb(ij))
     1556      fq(ij, inb(ij)) = fq(ij, inb(ij)) * (1. - frac(ij))
     1557      fq(ij, inb(ij) - 1) = fq(ij, inb(ij) - 1) + frac(ij) * fqold * ((ph(ij, &
     1558              inb(ij)) - ph(ij, inb(ij) + 1)) / (ph(ij, inb(ij) - 1) - ph(ij, &
     1559              inb(ij)))) * lv(ij, inb(ij)) / lv(ij, inb(ij) - 1)
     1560      ftold = ft(ij, inb(ij))
     1561      ft(ij, inb(ij)) = ft(ij, inb(ij)) * (1. - frac(ij))
     1562      ft(ij, inb(ij) - 1) = ft(ij, inb(ij) - 1) + frac(ij) * ftold * ((ph(ij, &
     1563              inb(ij)) - ph(ij, inb(ij) + 1)) / (ph(ij, inb(ij) - 1) - ph(ij, &
     1564              inb(ij)))) * cpn(ij, inb(ij)) / cpn(ij, inb(ij) - 1)
     1565      fuold = fu(ij, inb(ij))
     1566      fu(ij, inb(ij)) = fu(ij, inb(ij)) * (1. - frac(ij))
     1567      fu(ij, inb(ij) - 1) = fu(ij, inb(ij) - 1) + frac(ij) * fuold * ((ph(ij, &
     1568              inb(ij)) - ph(ij, inb(ij) + 1)) / (ph(ij, inb(ij) - 1) - ph(ij, inb(ij))))
     1569      fvold = fv(ij, inb(ij))
     1570      fv(ij, inb(ij)) = fv(ij, inb(ij)) * (1. - frac(ij))
     1571      fv(ij, inb(ij) - 1) = fv(ij, inb(ij) - 1) + frac(ij) * fvold * ((ph(ij, &
     1572              inb(ij)) - ph(ij, inb(ij) + 1)) / (ph(ij, inb(ij) - 1) - ph(ij, inb(ij))))
     1573    END DO
     1574
     1575    ! ***   Very slightly adjust tendencies to force exact   ***
     1576    ! ***     enthalpy, momentum and tracer conservation     ***
     1577
     1578    DO ij = 1, ncum
     1579      ents(ij) = 0.0
     1580      uav(ij) = 0.0
     1581      vav(ij) = 0.0
     1582      DO i = 1, inb(ij)
     1583        ents(ij) = ents(ij) + (cpn(ij, i) * ft(ij, i) + lv(ij, i) * fq(ij, i)) * (ph(ij, i) - &
     1584                ph(ij, i + 1))
     1585        uav(ij) = uav(ij) + fu(ij, i) * (ph(ij, i) - ph(ij, i + 1))
     1586        vav(ij) = vav(ij) + fv(ij, i) * (ph(ij, i) - ph(ij, i + 1))
     1587      END DO
     1588    END DO
     1589    DO ij = 1, ncum
     1590      ents(ij) = ents(ij) / (ph(ij, 1) - ph(ij, inb(ij) + 1))
     1591      uav(ij) = uav(ij) / (ph(ij, 1) - ph(ij, inb(ij) + 1))
     1592      vav(ij) = vav(ij) / (ph(ij, 1) - ph(ij, inb(ij) + 1))
     1593    END DO
     1594    DO ij = 1, ncum
     1595      DO i = 1, inb(ij)
     1596        ft(ij, i) = ft(ij, i) - ents(ij) / cpn(ij, i)
     1597        fu(ij, i) = (1. - cu) * (fu(ij, i) - uav(ij))
     1598        fv(ij, i) = (1. - cu) * (fv(ij, i) - vav(ij))
     1599      END DO
     1600    END DO
     1601
     1602    DO k = 1, nl + 1
     1603      DO i = 1, ncum
     1604        IF ((q(i, k) + delt * fq(i, k))<0.0) iflag(i) = 10
     1605      END DO
     1606    END DO
     1607
     1608    DO i = 1, ncum
     1609      IF (iflag(i)>2) THEN
     1610        precip(i) = 0.0
     1611        cbmf(i) = 0.0
     1612      END IF
     1613    END DO
     1614    DO k = 1, nl
     1615      DO i = 1, ncum
     1616        IF (iflag(i)>2) THEN
     1617          ft(i, k) = 0.0
     1618          fq(i, k) = 0.0
     1619          fu(i, k) = 0.0
     1620          fv(i, k) = 0.0
     1621          qcondc(i, k) = 0.0 ! cld
     1622        END IF
     1623      END DO
     1624    END DO
     1625
     1626    DO k = 1, nl + 1
     1627      DO i = 1, ncum
     1628        ma(i, k) = 0.
     1629      END DO
     1630    END DO
     1631    DO k = nl, 1, -1
     1632      DO i = 1, ncum
     1633        ma(i, k) = ma(i, k + 1) + m(i, k)
     1634      END DO
     1635    END DO
     1636
     1637
     1638    ! *** diagnose the in-cloud mixing ratio   ***            ! cld
     1639    ! ***           of condensed water         ***            ! cld
     1640    ! cld
     1641    DO ij = 1, ncum ! cld
     1642      DO i = 1, nd ! cld
     1643        mac(ij, i) = 0.0 ! cld
     1644        wa(ij, i) = 0.0 ! cld
     1645        siga(ij, i) = 0.0 ! cld
     1646      END DO ! cld
     1647      DO i = nk(ij), inb(ij) ! cld
     1648        DO k = i + 1, inb(ij) + 1 ! cld
     1649          mac(ij, i) = mac(ij, i) + m(ij, k) ! cld
    15181650        END DO ! cld
    1519         ! (particular case: no detraining level is found)            ! cld
    1520         IF (nent(ij, i)==0) THEN ! cld
    1521           qcond(ij, i) = qcond(ij, i) + (1. - ep(ij, i)) * clw(ij, i) ! cld
    1522           nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
     1651      END DO ! cld
     1652      DO i = icb(ij), inb(ij) - 1 ! cld
     1653        ax(ij, i) = 0. ! cld
     1654        DO j = icb(ij), i ! cld
     1655          ax(ij, i) = ax(ij, i) + rrd * (tvp(ij, j) - tv(ij, j)) & ! cld
     1656                  * (ph(ij, j) - ph(ij, j + 1)) / p(ij, j) ! cld
     1657        END DO ! cld
     1658        IF (ax(ij, i)>0.0) THEN ! cld
     1659          wa(ij, i) = sqrt(2. * ax(ij, i)) ! cld
    15231660        END IF ! cld
    1524         IF (nqcond(ij, i)/=0.) THEN ! cld
    1525           qcond(ij, i) = qcond(ij, i) / nqcond(ij, i) ! cld
    1526         END IF ! cld
    1527       END IF
    1528     END DO
    1529   1500 END DO
    1530 
    1531   ! *** Adjust tendencies at top of convection layer to reflect  ***
    1532   ! ***       actual position of the level zero cape             ***
    1533 
    1534   DO ij = 1, ncum
    1535     fqold = fq(ij, inb(ij))
    1536     fq(ij, inb(ij)) = fq(ij, inb(ij)) * (1. - frac(ij))
    1537     fq(ij, inb(ij) - 1) = fq(ij, inb(ij) - 1) + frac(ij) * fqold * ((ph(ij, &
    1538             inb(ij)) - ph(ij, inb(ij) + 1)) / (ph(ij, inb(ij) - 1) - ph(ij, &
    1539             inb(ij)))) * lv(ij, inb(ij)) / lv(ij, inb(ij) - 1)
    1540     ftold = ft(ij, inb(ij))
    1541     ft(ij, inb(ij)) = ft(ij, inb(ij)) * (1. - frac(ij))
    1542     ft(ij, inb(ij) - 1) = ft(ij, inb(ij) - 1) + frac(ij) * ftold * ((ph(ij, &
    1543             inb(ij)) - ph(ij, inb(ij) + 1)) / (ph(ij, inb(ij) - 1) - ph(ij, &
    1544             inb(ij)))) * cpn(ij, inb(ij)) / cpn(ij, inb(ij) - 1)
    1545     fuold = fu(ij, inb(ij))
    1546     fu(ij, inb(ij)) = fu(ij, inb(ij)) * (1. - frac(ij))
    1547     fu(ij, inb(ij) - 1) = fu(ij, inb(ij) - 1) + frac(ij) * fuold * ((ph(ij, &
    1548             inb(ij)) - ph(ij, inb(ij) + 1)) / (ph(ij, inb(ij) - 1) - ph(ij, inb(ij))))
    1549     fvold = fv(ij, inb(ij))
    1550     fv(ij, inb(ij)) = fv(ij, inb(ij)) * (1. - frac(ij))
    1551     fv(ij, inb(ij) - 1) = fv(ij, inb(ij) - 1) + frac(ij) * fvold * ((ph(ij, &
    1552             inb(ij)) - ph(ij, inb(ij) + 1)) / (ph(ij, inb(ij) - 1) - ph(ij, inb(ij))))
    1553   END DO
    1554 
    1555   ! ***   Very slightly adjust tendencies to force exact   ***
    1556   ! ***     enthalpy, momentum and tracer conservation     ***
    1557 
    1558   DO ij = 1, ncum
    1559     ents(ij) = 0.0
    1560     uav(ij) = 0.0
    1561     vav(ij) = 0.0
    1562     DO i = 1, inb(ij)
    1563       ents(ij) = ents(ij) + (cpn(ij, i) * ft(ij, i) + lv(ij, i) * fq(ij, i)) * (ph(ij, i) - &
    1564               ph(ij, i + 1))
    1565       uav(ij) = uav(ij) + fu(ij, i) * (ph(ij, i) - ph(ij, i + 1))
    1566       vav(ij) = vav(ij) + fv(ij, i) * (ph(ij, i) - ph(ij, i + 1))
    1567     END DO
    1568   END DO
    1569   DO ij = 1, ncum
    1570     ents(ij) = ents(ij) / (ph(ij, 1) - ph(ij, inb(ij) + 1))
    1571     uav(ij) = uav(ij) / (ph(ij, 1) - ph(ij, inb(ij) + 1))
    1572     vav(ij) = vav(ij) / (ph(ij, 1) - ph(ij, inb(ij) + 1))
    1573   END DO
    1574   DO ij = 1, ncum
    1575     DO i = 1, inb(ij)
    1576       ft(ij, i) = ft(ij, i) - ents(ij) / cpn(ij, i)
    1577       fu(ij, i) = (1. - cu) * (fu(ij, i) - uav(ij))
    1578       fv(ij, i) = (1. - cu) * (fv(ij, i) - vav(ij))
    1579     END DO
    1580   END DO
    1581 
    1582   DO k = 1, nl + 1
    1583     DO i = 1, ncum
    1584       IF ((q(i, k) + delt * fq(i, k))<0.0) iflag(i) = 10
    1585     END DO
    1586   END DO
    1587 
    1588   DO i = 1, ncum
    1589     IF (iflag(i)>2) THEN
    1590       precip(i) = 0.0
    1591       cbmf(i) = 0.0
    1592     END IF
    1593   END DO
    1594   DO k = 1, nl
    1595     DO i = 1, ncum
    1596       IF (iflag(i)>2) THEN
    1597         ft(i, k) = 0.0
    1598         fq(i, k) = 0.0
    1599         fu(i, k) = 0.0
    1600         fv(i, k) = 0.0
    1601         qcondc(i, k) = 0.0 ! cld
    1602       END IF
    1603     END DO
    1604   END DO
    1605 
    1606   DO k = 1, nl + 1
    1607     DO i = 1, ncum
    1608       ma(i, k) = 0.
    1609     END DO
    1610   END DO
    1611   DO k = nl, 1, -1
    1612     DO i = 1, ncum
    1613       ma(i, k) = ma(i, k + 1) + m(i, k)
    1614     END DO
    1615   END DO
    1616 
    1617 
    1618   ! *** diagnose the in-cloud mixing ratio   ***            ! cld
    1619   ! ***           of condensed water         ***            ! cld
    1620   ! cld
    1621   DO ij = 1, ncum ! cld
    1622     DO i = 1, nd ! cld
    1623       mac(ij, i) = 0.0 ! cld
    1624       wa(ij, i) = 0.0 ! cld
    1625       siga(ij, i) = 0.0 ! cld
    1626     END DO ! cld
    1627     DO i = nk(ij), inb(ij) ! cld
    1628       DO k = i + 1, inb(ij) + 1 ! cld
    1629         mac(ij, i) = mac(ij, i) + m(ij, k) ! cld
     1661      END DO ! cld
     1662      DO i = 1, nl ! cld
     1663        IF (wa(ij, i)>0.0) &          ! cld
     1664                siga(ij, i) = mac(ij, i) / wa(ij, i) & ! cld
     1665                        * rrd * tvp(ij, i) / p(ij, i) / 100. / delta ! cld
     1666        siga(ij, i) = min(siga(ij, i), 1.0) ! cld
     1667        qcondc(ij, i) = siga(ij, i) * clw(ij, i) * (1. - ep(ij, i)) & ! cld
     1668                + (1. - siga(ij, i)) * qcond(ij, i) ! cld
    16301669      END DO ! cld
    16311670    END DO ! cld
    1632     DO i = icb(ij), inb(ij) - 1 ! cld
    1633       ax(ij, i) = 0. ! cld
    1634       DO j = icb(ij), i ! cld
    1635         ax(ij, i) = ax(ij, i) + rrd * (tvp(ij, j) - tv(ij, j)) & ! cld
    1636                 * (ph(ij, j) - ph(ij, j + 1)) / p(ij, j) ! cld
    1637       END DO ! cld
    1638       IF (ax(ij, i)>0.0) THEN ! cld
    1639         wa(ij, i) = sqrt(2. * ax(ij, i)) ! cld
    1640       END IF ! cld
    1641     END DO ! cld
    1642     DO i = 1, nl ! cld
    1643       IF (wa(ij, i)>0.0) &          ! cld
    1644               siga(ij, i) = mac(ij, i) / wa(ij, i) & ! cld
    1645                       * rrd * tvp(ij, i) / p(ij, i) / 100. / delta ! cld
    1646       siga(ij, i) = min(siga(ij, i), 1.0) ! cld
    1647       qcondc(ij, i) = siga(ij, i) * clw(ij, i) * (1. - ep(ij, i)) & ! cld
    1648               + (1. - siga(ij, i)) * qcond(ij, i) ! cld
    1649     END DO ! cld
    1650   END DO ! cld
    1651 
    1652 END SUBROUTINE cv_yield
    1653 
    1654 SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, iflag, precip, cbmf, ft, &
    1655         fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, ma1, &
    1656         qcondc1)
    1657   IMPLICIT NONE
    1658 
    1659   include "cvparam.h"
    1660 
    1661   ! inputs:
    1662   INTEGER len, ncum, nd, nloc
    1663   INTEGER idcum(nloc)
    1664   INTEGER iflag(nloc)
    1665   REAL precip(nloc), cbmf(nloc)
    1666   REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
    1667   REAL ma(nloc, nd)
    1668   REAL qcondc(nloc, nd) !cld
    1669 
    1670   ! outputs:
    1671   INTEGER iflag1(len)
    1672   REAL precip1(len), cbmf1(len)
    1673   REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
    1674   REAL ma1(len, nd)
    1675   REAL qcondc1(len, nd) !cld
    1676 
    1677   ! local variables:
    1678   INTEGER i, k
    1679 
    1680   DO i = 1, ncum
    1681     precip1(idcum(i)) = precip(i)
    1682     cbmf1(idcum(i)) = cbmf(i)
    1683     iflag1(idcum(i)) = iflag(i)
    1684   END DO
    1685 
    1686   DO k = 1, nl
    1687     DO i = 1, ncum
    1688       ft1(idcum(i), k) = ft(i, k)
    1689       fq1(idcum(i), k) = fq(i, k)
    1690       fu1(idcum(i), k) = fu(i, k)
    1691       fv1(idcum(i), k) = fv(i, k)
    1692       ma1(idcum(i), k) = ma(i, k)
    1693       qcondc1(idcum(i), k) = qcondc(i, k)
    1694     END DO
    1695   END DO
    1696 
    1697 END SUBROUTINE cv_uncompress
    1698 
     1671
     1672  END SUBROUTINE cv_yield
     1673
     1674  SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, iflag, precip, cbmf, ft, &
     1675          fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, ma1, &
     1676          qcondc1)
     1677    IMPLICIT NONE
     1678
     1679
     1680    ! inputs:
     1681    INTEGER len, ncum, nd, nloc
     1682    INTEGER idcum(nloc)
     1683    INTEGER iflag(nloc)
     1684    REAL precip(nloc), cbmf(nloc)
     1685    REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
     1686    REAL ma(nloc, nd)
     1687    REAL qcondc(nloc, nd) !cld
     1688
     1689    ! outputs:
     1690    INTEGER iflag1(len)
     1691    REAL precip1(len), cbmf1(len)
     1692    REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
     1693    REAL ma1(len, nd)
     1694    REAL qcondc1(len, nd) !cld
     1695
     1696    ! local variables:
     1697    INTEGER i, k
     1698
     1699    DO i = 1, ncum
     1700      precip1(idcum(i)) = precip(i)
     1701      cbmf1(idcum(i)) = cbmf(i)
     1702      iflag1(idcum(i)) = iflag(i)
     1703    END DO
     1704
     1705    DO k = 1, nl
     1706      DO i = 1, ncum
     1707        ft1(idcum(i), k) = ft(i, k)
     1708        fq1(idcum(i), k) = fq(i, k)
     1709        fu1(idcum(i), k) = fu(i, k)
     1710        fv1(idcum(i), k) = fv(i, k)
     1711        ma1(idcum(i), k) = ma(i, k)
     1712        qcondc1(idcum(i), k) = qcondc(i, k)
     1713      END DO
     1714    END DO
     1715
     1716  END SUBROUTINE cv_uncompress
     1717
     1718
     1719END MODULE lmdz_cv

  • LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_dimpft.f90

    r5141 r5142  
     1MODULE lmdz_dimpft
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC nvm_lmdz
    14
    2 ! $Id$
    3 
    4       INTEGER nvm_lmdz
    5 !      PARAMETER (nvm_lmdz=13)
    6       COMMON /dimpft/ nvm_lmdz
     5  INTEGER nvm_lmdz
     6END MODULE lmdz_dimpft

  • LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_fcg_gcssold.f90

    r5141 r5142  
     1MODULE lmdz_fcs_gcssold
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC imp_fcg_gcssold, ts_fcg_gcssold, Tp_fcg_gcssold, Tp_ini_gcssold, xTurb_fcg_gcssold
    14
    2 ! $Id: fcg_gcssold.h 2010-08-10 17:02:56Z lahellec $
     5  LOGICAL :: imp_fcg_gcssold, ts_fcg_gcssold, Tp_fcg_gcssold
     6  LOGICAL :: Tp_ini_gcssold
     7  LOGICAL :: xTurb_fcg_gcssold
    38
    4       LOGICAL :: imp_fcg_gcssold,ts_fcg_gcssold,Tp_fcg_gcssold
    5       LOGICAL :: Tp_ini_gcssold
    6       LOGICAL :: xTurb_fcg_gcssold
    7 
    8       common /fcg_gcssold/imp_fcg_gcssold,ts_fcg_gcssold,Tp_fcg_gcssold,        &
    9        Tp_ini_gcssold,                                                          &
    10        xTurb_fcg_gcssold
    11 
    12 !$OMP THREADPRIVATE(/fcg_gcssold/)
     9  !$OMP THREADPRIVATE(imp_fcg_gcssold, ts_fcg_gcssold, Tp_fcg_gcssold, Tp_ini_gcssold, xTurb_fcg_gcssold)
     10END MODULE lmdz_fcs_gcssold
    1311
    1412
    … …  
    4442
    4543
    46 

  • LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_planete.f90

    r5141 r5142  
    1 !-----------------------------------------------------------------------
    2 ! INCLUDE planet.h
     1MODULE lmdz_planete
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC aphelie, periheli, year_day, peri_day, obliquit, timeperi, e_elips, p_elips, unitastr
    34
    4       COMMON/planet/aphelie,periheli,year_day,peri_day, obliquit, timeperi,&
    5            e_elips,p_elips,unitastr
     5  REAL aphelie, periheli, year_day, peri_day, obliquit, timeperi, e_elips, &
     6          p_elips, unitastr
    67
    7       REAL aphelie,periheli,year_day,peri_day, obliquit, timeperi,e_elips, &
    8            p_elips,unitastr
    9 
    10 !-----------------------------------------------------------------------
    11 !$OMP THREADPRIVATE(/planet/)
     8  !$OMP THREADPRIVATE(aphelie, periheli, year_day, peri_day, obliquit, timeperi, e_elips, p_elips, unitastr)
     9END MODULE lmdz_planete

  • LMDZ6/branches/Amaury_dev/libf/phylmd/lmdz_tsoilnudge.f90

    r5141 r5142  
    1       LOGICAL nudge_tsoil
    2       INTEGER isoil_nudge
    3       REAL Tsoil_nudge, tau_soil_nudge
     1MODULE lmdz_tsoilnudge
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC nudge_tsoil, isoil_nudge, Tsoil_nudge, tau_soil_nudge
    44
    5       common /tsoilnudge/ nudge_tsoil, isoil_nudge, Tsoil_nudge,        &
    6                          tau_soil_nudge
    7 
     5  LOGICAL nudge_tsoil
     6  INTEGER isoil_nudge
     7  REAL Tsoil_nudge, tau_soil_nudge
     8END MODULE lmdz_tsoilnudge

  • LMDZ6/branches/Amaury_dev/libf/phylmd/lsc_scav.F90

    r5117 r5142  
    1212  USE infotrac_phy,ONLY: nbtr
    1313  USE iophy
     14  USE lmdz_YOECUMF
     15
    1416  IMPLICIT NONE
    1517!=====================================================================
    … …  
    2224  include "chem.h"
    2325  include "YOMCST.h"
    24   include "YOECUMF.h"
    2526
    2627! inputs

  • LMDZ6/branches/Amaury_dev/libf/phylmd/nflxtr.F90

    r5116 r5142  
    44SUBROUTINE nflxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,pplay,paprs,x,dx)
    55  USE dimphy
     6  USE lmdz_YOECUMF
     7
    68  IMPLICIT NONE
    79!=====================================================================
    … …  
    2224
    2325  include "YOMCST.h"
    24   include "YOECUMF.h"
    2526
    2627  REAL,INTENT(IN) :: pdtime  ! pdtphys

  • LMDZ6/branches/Amaury_dev/libf/phylmd/pbl_surface_mod.F90

    r5139 r5142  
    417417  USE lmdz_flux_arp, ONLY: fsens, flat, betaevap, ust, tg, ok_flux_surf, ok_prescr_ust, ok_prescr_beta, ok_forc_tsurf
    418418  USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree
     419  USE lmdz_dimpft, ONLY: nvm_lmdz
    419420
    420421    IMPLICIT NONE
    … …  
    424425    INCLUDE "YOETHF.h"
    425426    INCLUDE "FCTTRE.h"
    426     !FC
    427     INCLUDE "dimpft.h"
    428427
    429428    !****************************************************************************************

  • LMDZ6/branches/Amaury_dev/libf/phylmd/physiq_mod.F90

    r5140 r5142  
    355355    USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree
    356356    USE lmdz_conema3
     357    USE lmdz_dimpft, ONLY: nvm_lmdz
    357358
    358359    IMPLICIT NONE
    … …  
    409410    include "regdim.h"
    410411    include "dimsoil.h"
    411     include "dimpft.h"
    412412    !======================================================================
    413413    LOGICAL, SAVE :: ok_volcan ! pour activer les diagnostics volcaniques

  • LMDZ6/branches/Amaury_dev/libf/phylmd/solarlong.F90

    r5112 r5142  
    33  USE ioipsl
    44  USE lmdz_print_control, ONLY: lunout
     5  USE lmdz_planete, ONLY: aphelie, periheli, year_day, peri_day, obliquit, timeperi, e_elips, p_elips, unitastr
    56
    67  IMPLICIT NONE
    … …  
    4445  ! Declarations:
    4546  ! -------------
    46 
    47   include "planete.h"
    4847  include "YOMCST.h"
    4948
    … …  
    8382  ! calcul de l'zanomalie moyenne
    8483
    85   zz = (pday-peri_day)/year_day
    86   pi = 2.*asin(1.)
    87   zanom = 2.*pi*(zz-nint(zz))
     84  zz = (pday - peri_day) / year_day
     85  pi = 2. * asin(1.)
     86  zanom = 2. * pi * (zz - nint(zz))
    8887  xref = abs(zanom)
    8988
    … …  
    9291
    9392  ! zx0=xref+e_elips*sin(xref)
    94   zx0 = xref + r_ecc*sin(xref)
     93  zx0 = xref + r_ecc * sin(xref)
    9594  DO iter = 1, 10
    9695    ! zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0))
    97     zdx = -(zx0-r_ecc*sin(zx0)-xref)/(1.-r_ecc*cos(zx0))
     96    zdx = -(zx0 - r_ecc * sin(zx0) - xref) / (1. - r_ecc * cos(zx0))
    9897    IF (abs(zdx)<=(1.E-7)) GO TO 120
    9998    zx0 = zx0 + zdx
    10099  END DO
    101 120 CONTINUE
     100  120 CONTINUE
    102101  zx0 = zx0 + zdx
    103102  IF (zanom<0.) zx0 = -zx0
    … …  
    106105
    107106  ! zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.))
    108   zteta = 2.*atan(sqrt((1.+r_ecc)/(1.-r_ecc))*tan(zx0/2.))
     107  zteta = 2. * atan(sqrt((1. + r_ecc) / (1. - r_ecc)) * tan(zx0 / 2.))
    109108
    110109  psollong = zteta - timeperi
    111110
    112   IF (psollong<0.) psollong = psollong + 2.*pi
    113   IF (psollong>2.*pi) psollong = psollong - 2.*pi
     111  IF (psollong<0.) psollong = psollong + 2. * pi
     112  IF (psollong>2. * pi) psollong = psollong - 2. * pi
    114113
    115   psollong = psollong*180./pi
     114  psollong = psollong * 180. / pi
    116115
    117116  ! distance soleil
    118117
    119   pdist_sol = (1-r_ecc*r_ecc)/(1+r_ecc*cos(pi/180.*(psollong- &
    120     (r_peri+180.0))))
     118  pdist_sol = (1 - r_ecc * r_ecc) / (1 + r_ecc * cos(pi / 180. * (psollong - &
     119          (r_peri + 180.0))))
    121120  ! pdist_sol = (1-e_elips*e_elips)
    122121  ! &      /(1+e_elips*COS(pi/180.*(psollong-(R_peri+180.0))))
    … …  
    131130  ! ENDIF
    132131
    133 
    134132END SUBROUTINE solarlong

  • LMDZ6/branches/Amaury_dev/libf/phylmd/surf_land_mod.F90

    r5137 r5142  
    7575    USE lmdz_print_control, ONLY: lunout
    7676  USE lmdz_clesphys
     77  USE lmdz_dimpft, ONLY: nvm_lmdz
    7778
    7879    INCLUDE "dimsoil.h"
    7980    INCLUDE "YOMCST.h"
    80     INCLUDE "dimpft.h"
    8181
    8282! Input variables 

  • LMDZ6/branches/Amaury_dev/libf/phylmd/surf_land_orchidee_mod.F90

    r5117 r5142  
    5858    USE lmdz_print_control, ONLY: lunout
    5959    USE lmdz_grid_phy, ONLY: nbp_lon, nbp_lat
     60    USE lmdz_dimpft, ONLY: nvm_lmdz
    6061#ifdef CPP_VEGET
    6162    USE time_phylmdz_mod, ONLY: itau_phy
    … …  
    114115
    115116    INCLUDE "YOMCST.h"
    116     INCLUDE "dimpft.h"
    117117
    118118    ! Parametres d'entree

  • LMDZ6/branches/Amaury_dev/libf/phylmd/surf_land_orchidee_nofrein_mod.F90

    r5139 r5142  
    6161    USE time_phylmdz_mod, ONLY: itau_phy
    6262#endif
     63USE lmdz_dimpft, ONLY: nvm_lmdz
    6364
    6465! Cette routine sert d'interface entre le modele atmospherique et le
    … …  
    115116
    116117    INCLUDE "YOMCST.h"
    117     INCLUDE "dimpft.h"
    118118
    119119! Parametres d'entree

  • LMDZ6/branches/Amaury_dev/libf/phylmd/surf_land_orchidee_nolic_mod.F90

    r5117 r5142  
    5757    USE time_phylmdz_mod, ONLY: itau_phy
    5858#endif
     59USE lmdz_dimpft, ONLY: nvm_lmdz
    5960
    6061! Cette routine sert d'interface entre le modele atmospherique et le
    … …  
    110111
    111112    INCLUDE "YOMCST.h"
    112     INCLUDE "dimpft.h"
    113113
    114114! Parametres d'entree

  • LMDZ6/branches/Amaury_dev/libf/phylmd/surf_land_orchidee_noopenmp_mod.F90

    r5117 r5142  
    106106    USE time_phylmdz_mod, ONLY: itau_phy
    107107#endif
     108USE lmdz_dimpft, ONLY: nvm_lmdz
     109
    108110    IMPLICIT NONE
    109111
    110112    INCLUDE "YOMCST.h"
    111     INCLUDE "dimpft.h" 
    112113
    113114! Parametres d'entree

  • LMDZ6/branches/Amaury_dev/libf/phylmd/surf_land_orchidee_nounstruct_mod.F90

    r5117 r5142  
    5656    USE time_phylmdz_mod, ONLY: itau_phy
    5757#endif
     58USE lmdz_dimpft, ONLY: nvm_lmdz
    5859
    5960! Cette routine sert d'interface entre le modele atmospherique et le
    … …  
    110111
    111112    INCLUDE "YOMCST.h"
    112     INCLUDE "dimpft.h"
    113113
    114114! Parametres d'entree

  • LMDZ6/branches/Amaury_dev/libf/phylmd/surf_land_orchidee_noz0h_mod.F90

    r5139 r5142  
    5959    USE time_phylmdz_mod, ONLY: itau_phy
    6060#endif
     61USE lmdz_dimpft, ONLY: nvm_lmdz
    6162
    6263! Cette routine sert d'interface entre le modele atmospherique et le
    … …  
    113114
    114115    INCLUDE "YOMCST.h"
    115     INCLUDE "dimpft.h" 
    116116
    117117! Parametres d'entree

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv_driver.F90

    r5141 r5142  
    4444USE lmdz_cv30, ONLY: cv30_param, cv30_prelim, cv30_feed, cv30_undilute1, cv30_trigger, cv30_compress, cv30_undilute2, &
    4545          cv30_closure, cv30_epmax_fn_cape, cv30_mixing, cv30_unsat, cv30_yield, cv30_tracer, cv30_uncompress
     46USE lmdz_cv, ONLY: cv_param, cv_prelim, cv_feed, cv_undilute1, cv_trigger, cv_compress, &
     47          cv_undilute2, cv_closure, cv_mixing, cv_unsat, cv_yield, cv_uncompress
    4648
    4749  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/cva_driver.F90

    r5136 r5142  
    7373#endif
    7474#endif
     75USE lmdz_cv, ONLY: cv_param, cv_prelim, cv_feed, cv_undilute1, cv_trigger, cv_compress, &
     76          cv_undilute2, cv_closure, cv_mixing, cv_unsat, cv_yield, cv_uncompress
     77
    7578  IMPLICIT NONE
    7679

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_YOECUMF.f90

    r5141 r5142  
    1 link ../phylmd/YOECUMF.h
     1link ../phylmd/lmdz_YOECUMF.f90

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_cv.F90

    r5141 r5142  
    11! $Id$
     2
     3MODULE lmdz_cv
     4  !------------------------------------------------------------
     5  ! Parameters for convectL:
     6  ! (includes - microphysical parameters,
     7  !                     - parameters that control the rate of approach
     8  !               to quasi-equilibrium)
     9  !                     - noff & minorig (previously in input of convect1)
     10  !------------------------------------------------------------
     11
     12  IMPLICIT NONE; PRIVATE
     13  PUBLIC elcrit, tlcrit, entp, sigs, sigd, omtrain, omtsnow, coeffr, coeffs &
     14          , dtmax, cu, betad, alpha, damp, delta, noff, minorig, nl, nlp, nlm, &
     15          cv_param, cv_prelim, cv_feed, cv_undilute1, cv_trigger, cv_compress, &
     16          cv_undilute2, cv_closure, cv_mixing, cv_unsat, cv_yield, cv_uncompress
     17
     18  INTEGER noff, minorig, nl, nlp, nlm
     19  REAL elcrit, tlcrit
     20  REAL entp
     21  REAL sigs, sigd
     22  REAL omtrain, omtsnow, coeffr, coeffs
     23  REAL dtmax
     24  REAL cu
     25  REAL betad
     26  REAL alpha, damp
     27  REAL delta
     28
     29  !$OMP THREADPRIVATE(elcrit, tlcrit, entp, sigs, sigd, omtrain, omtsnow, coeffr, coeffs &
     30  !$OMP      , dtmax, cu, betad, alpha, damp, delta, noff, minorig, nl, nlp, nlm)
     31
     32CONTAINS
    233
    334SUBROUTINE cv_param(nd)
    … …  
    3566  ! ***                   (DAMP MUST BE LESS THAN 1)                 ***
    3667
    37   include "cvparam.h"
    38   INTEGER nd
     68    INTEGER nd
    3969  CHARACTER (LEN = 20) :: modname = 'cv_routines'
    4070  CHARACTER (LEN = 80) :: abort_message
    … …  
    93123  REAL cpx(len, nd)
    94124
    95   include "cvparam.h"
    96 
     125 
    97126  DO k = 1, nlp
    98127    DO i = 1, len
    … …  
    136165  ! ================================================================
    137166
    138   include "cvparam.h"
    139 
     167 
    140168  ! inputs:
    141169  INTEGER len, nd
    … …  
    254282  IMPLICIT NONE
    255283
    256   include "cvparam.h"
    257 
     284 
    258285  ! inputs:
    259286  INTEGER len, nd
    … …  
    367394  ! -------------------------------------------------------------------
    368395
    369   include "cvparam.h"
    370 
     396 
    371397  ! inputs:
    372398  INTEGER len, nd, icb(len)
    … …  
    394420  IMPLICIT NONE
    395421
    396   include "cvparam.h"
    397 
     422 
    398423  ! inputs:
    399424  INTEGER len, ncum, nd, nloc
    … …  
    488513  ! ---------------------------------------------------------------------
    489514
    490   include "cvparam.h"
    491 
     515 
    492516  ! inputs:
    493517  INTEGER ncum, nd, nloc
    … …  
    775799  REAL work(nloc)
    776800
    777   include "cvparam.h"
    778 
     801 
    779802  ! -------------------------------------------------------------------
    780803  ! Compute icbmax.
    … …  
    842865  IMPLICIT NONE
    843866
    844   include "cvparam.h"
    845 
     867 
    846868  ! inputs:
    847869  INTEGER ncum, nd, nloc
    … …  
    10921114  IMPLICIT NONE
    10931115
    1094   include "cvparam.h"
    1095 
     1116 
    10961117  ! inputs:
    10971118  INTEGER ncum, nd, nloc
    … …  
    12921313  IMPLICIT NONE
    12931314
    1294   include "cvparam.h"
    1295 
     1315 
    12961316  ! inputs
    12971317  INTEGER ncum, nd, nloc
    … …  
    16571677  IMPLICIT NONE
    16581678
    1659   include "cvparam.h"
    1660 
     1679 
    16611680  ! inputs:
    16621681  INTEGER len, ncum, nd, nloc
    … …  
    16971716END SUBROUTINE cv_uncompress
    16981717
     1718
     1719END MODULE lmdz_cv

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_dimpft.f90

    r5141 r5142  
    1 link ../phylmd/dimpft.h
     1link ../phylmd/lmdz_dimpft.f90

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_fcg_gcssold.f90

    r5141 r5142  
    1 link ../phylmd/fcg_gcssold.h
     1link ../phylmd/lmdz_fcg_gcssold.f90

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_planete.f90

    r5141 r5142  
    1 link ../phylmd/planete.h
     1link ../phylmd/lmdz_planete.f90

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/lmdz_tsoilnudge.f90

    r5141 r5142  
    1 link ../phylmd/tsoilnudge.h
     1link ../phylmd/lmdz_tsoilnudge.f90

  • LMDZ6/branches/Amaury_dev/libf/phylmdiso/physiq_mod.F90

    r5140 r5142  
    423423    USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree
    424424    USE lmdz_conema3
     425    USE lmdz_dimpft, ONLY: nvm_lmdz
    425426
    426427    IMPLICIT NONE
    … …  
    477478    include "regdim.h"
    478479    include "dimsoil.h"
    479     include "dimpft.h"
    480480    !======================================================================
    481481    LOGICAL, SAVE :: ok_volcan ! pour activer les diagnostics volcaniques
Note: See TracChangeset for help on using the changeset viewer.