Ignore:
Timestamp:
Jul 29, 2024, 5:47:53 PM (5 months ago)
Author:
abarral
Message:

Put YOEGWD.h, FCTTRE.h into modules

Location:
LMDZ6/branches/Amaury_dev/libf/phylmd
Files:
51 edited
3 moved

Legend:

Unmodified
Added
Removed

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

    r5113 r5143  
    22        , t, q, tsol, ustar, obklen)
    33  USE dimphy
     4  USE lmdz_YOETHF
     5  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     6
    47  IMPLICIT NONE
    58  !
    … …  
    1922  INCLUDE "dimensions.h"
    2023  INCLUDE "YOMCST.h"
    21   INCLUDE "YOETHF.h"
    22   INCLUDE "FCTTRE.h"
    2324  !
    2425  ! Arguments :

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

    r5134 r5143  
    799799    USE lmdz_yomcst
    800800    USE lmdz_alpale
     801    USE lmdz_YOETHF
    801802
    802803    IMPLICIT NONE
    … …  
    816817    INCLUDE "chem.h"
    817818    INCLUDE "chem_spla.h"
    818     INCLUDE "YOETHF.h"
    819819    INCLUDE "paramet.h"
    820820

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

    r5137 r5143  
    2727    USE lmdz_abort_physic, ONLY: abort_physic
    2828    USE lmdz_clesphys
     29    USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     30          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
    2931
    3032    include "YOMCST.h"
    … …  
    3335!   include "dimphy.h"
    3436!END DIFFERENCE
    35     include "YOEGWD.h"
    3637
    3738    ! 0. DECLARATIONS:

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

    r5082 r5143  
    1 SUBROUTINE borne_var_surf(klon,klev,nbsrf,                  &
    2          iflag_bug_t2m_stab_ipslcm61,                        &
    3          t1,q1,u1,v1,                                        &
    4          ftsol, qsurf, pctsrf, paprs,                        &
    5          t2m, q2m, u10m, v10m,                              &
    6          zt2m_cor, zq2m_cor, zu10m_cor, zv10m_cor,          &
    7          zrh2m_cor, zqsat2m_cor)
     1SUBROUTINE borne_var_surf(klon, klev, nbsrf, &
     2        iflag_bug_t2m_stab_ipslcm61, &
     3        t1, q1, u1, v1, &
     4        ftsol, qsurf, pctsrf, paprs, &
     5        t2m, q2m, u10m, v10m, &
     6        zt2m_cor, zq2m_cor, zu10m_cor, zv10m_cor, &
     7        zrh2m_cor, zqsat2m_cor)
    88
    9 IMPLICIT NONE
     9  USE lmdz_YOETHF
     10  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    1011
    11 !==================================================================
    12 ! Declarations
    13 !==================================================================
     12  IMPLICIT NONE
    1413
    15 ! arguments
    16 INTEGER klon,klev,nbsrf,iflag_bug_t2m_stab_ipslcm61
    17 REAL,DIMENSION(klon),INTENT(IN) :: t1, q1, u1, v1
    18 REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: t2m, q2m, u10m, v10m
    19 REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol, pctsrf
    20 REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs
    21 REAL,DIMENSION(klon),INTENT(IN) :: qsurf
    22 REAL,DIMENSION (klon),INTENT(OUT) :: zt2m_cor, zq2m_cor, zu10m_cor, zv10m_cor
    23 REAL,DIMENSION (klon),INTENT(OUT)  :: zrh2m_cor, zqsat2m_cor
     14  !==================================================================
     15  ! Declarations
     16  !==================================================================
    2417
     18  ! arguments
     19  INTEGER klon, klev, nbsrf, iflag_bug_t2m_stab_ipslcm61
     20  REAL, DIMENSION(klon), INTENT(IN) :: t1, q1, u1, v1
     21  REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: t2m, q2m, u10m, v10m
     22  REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: ftsol, pctsrf
     23  REAL, DIMENSION(klon, klev + 1), INTENT(IN) :: paprs
     24  REAL, DIMENSION(klon), INTENT(IN) :: qsurf
     25  REAL, DIMENSION (klon), INTENT(OUT) :: zt2m_cor, zq2m_cor, zu10m_cor, zv10m_cor
     26  REAL, DIMENSION (klon), INTENT(OUT) :: zrh2m_cor, zqsat2m_cor
    2527
    26 ! local
    27 INTEGER i,nsrf
    28 REAL,DIMENSION (klon,nbsrf) :: t2m_cor, q2m_cor, u10m_cor, v10m_cor
    29 REAL                               :: zx_qs1, zcor1, zdelta1
    30 include "YOMCST.h"
    31 include "YOETHF.h"
    32 include "FCTTRE.h"
    33 !==================================================================
    34 ! Correction of sub surface variables
    35 !==================================================================
     28  ! local
     29  INTEGER i, nsrf
     30  REAL, DIMENSION (klon, nbsrf) :: t2m_cor, q2m_cor, u10m_cor, v10m_cor
     31  REAL :: zx_qs1, zcor1, zdelta1
     32  include "YOMCST.h"
     33  !==================================================================
     34  ! Correction of sub surface variables
     35  !==================================================================
    3636
    37 zrh2m_cor=0.
    38 zqsat2m_cor=0.
     37  zrh2m_cor = 0.
     38  zqsat2m_cor = 0.
    3939
    40 DO nsrf=1,nbsrf
    41    DO i=1,klon
    42     t2m_cor(i,nsrf)=t2m(i,nsrf)
    43     q2m_cor(i,nsrf)=q2m(i,nsrf)
    44     u10m_cor(i,nsrf)=u10m(i,nsrf)
    45     v10m_cor(i,nsrf)=v10m(i,nsrf)
    46      IF(iflag_bug_t2m_stab_ipslcm61==-2.AND.q2m(i,nsrf)<0.) THEN
    47       t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
    48       t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
    49       q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
    50       q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
    51       q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
    52       u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
    53       v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
    54      ELSEIF(iflag_bug_t2m_stab_ipslcm61==-1.AND.(ftsol(i,nsrf)<=t1(i).OR.q2m(i,nsrf)<0.)) THEN
    55       t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
    56       t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
    57       q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
    58       q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
    59       q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
    60       u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
    61       v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
    62      ELSEIF(iflag_bug_t2m_stab_ipslcm61==1.AND.ftsol(i,nsrf)<=t1(i)) THEN
    63       t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
    64       t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
    65       q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
    66       q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
    67       q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
    68       u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
    69       v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
    70      ELSEIF(iflag_bug_t2m_stab_ipslcm61==0) THEN
    71       t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
    72       t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
    73       q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
    74       q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
    75       q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
    76       u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
    77       v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
    78      ENDIF
    79 !!!
    80      zdelta1 = MAX(0.,SIGN(1., rtt-t2m_cor(i,nsrf) ))
    81      zx_qs1  = r2es * FOEEW(t2m_cor(i,nsrf),zdelta1)/paprs(i,1)
    82      zx_qs1  = MIN(0.5,zx_qs1)
    83      zcor1   = 1./(1.-RETV*zx_qs1)
    84      zx_qs1  = zx_qs1*zcor1
    85      zrh2m_cor(i) = zrh2m_cor(i) + q2m_cor(i,nsrf)/zx_qs1 * pctsrf(i,nsrf)
    86      zqsat2m_cor(i) = zqsat2m_cor(i) + zx_qs1  * pctsrf(i,nsrf)
    87 !!!
    88    ENDDO
    89 ENDDO
     40  DO nsrf = 1, nbsrf
     41    DO i = 1, klon
     42      t2m_cor(i, nsrf) = t2m(i, nsrf)
     43      q2m_cor(i, nsrf) = q2m(i, nsrf)
     44      u10m_cor(i, nsrf) = u10m(i, nsrf)
     45      v10m_cor(i, nsrf) = v10m(i, nsrf)
     46      IF(iflag_bug_t2m_stab_ipslcm61==-2.AND.q2m(i, nsrf)<0.) THEN
     47        t2m_cor(i, nsrf) = MIN(t2m(i, nsrf), MAX(t1(i), ftsol(i, nsrf)))
     48        t2m_cor(i, nsrf) = MAX(t2m_cor(i, nsrf), MIN(t1(i), ftsol(i, nsrf)))
     49        q2m_cor(i, nsrf) = MIN(q2m(i, nsrf), MAX(q1(i), qsurf(i)))
     50        q2m_cor(i, nsrf) = MAX(q2m_cor(i, nsrf), MIN(q1(i), qsurf(i)))
     51        q2m_cor(i, nsrf) = MAX(q2m_cor(i, nsrf), 0.)
     52        u10m_cor(i, nsrf) = SIGN(MIN(ABS(u1(i)), ABS(u10m(i, nsrf))), u1(i))
     53        v10m_cor(i, nsrf) = SIGN(MIN(ABS(v1(i)), ABS(v10m(i, nsrf))), v1(i))
     54      ELSEIF(iflag_bug_t2m_stab_ipslcm61==-1.AND.(ftsol(i, nsrf)<=t1(i).OR.q2m(i, nsrf)<0.)) THEN
     55        t2m_cor(i, nsrf) = MIN(t2m(i, nsrf), MAX(t1(i), ftsol(i, nsrf)))
     56        t2m_cor(i, nsrf) = MAX(t2m_cor(i, nsrf), MIN(t1(i), ftsol(i, nsrf)))
     57        q2m_cor(i, nsrf) = MIN(q2m(i, nsrf), MAX(q1(i), qsurf(i)))
     58        q2m_cor(i, nsrf) = MAX(q2m_cor(i, nsrf), MIN(q1(i), qsurf(i)))
     59        q2m_cor(i, nsrf) = MAX(q2m_cor(i, nsrf), 0.)
     60        u10m_cor(i, nsrf) = SIGN(MIN(ABS(u1(i)), ABS(u10m(i, nsrf))), u1(i))
     61        v10m_cor(i, nsrf) = SIGN(MIN(ABS(v1(i)), ABS(v10m(i, nsrf))), v1(i))
     62      ELSEIF(iflag_bug_t2m_stab_ipslcm61==1.AND.ftsol(i, nsrf)<=t1(i)) THEN
     63        t2m_cor(i, nsrf) = MIN(t2m(i, nsrf), MAX(t1(i), ftsol(i, nsrf)))
     64        t2m_cor(i, nsrf) = MAX(t2m_cor(i, nsrf), MIN(t1(i), ftsol(i, nsrf)))
     65        q2m_cor(i, nsrf) = MIN(q2m(i, nsrf), MAX(q1(i), qsurf(i)))
     66        q2m_cor(i, nsrf) = MAX(q2m_cor(i, nsrf), MIN(q1(i), qsurf(i)))
     67        q2m_cor(i, nsrf) = MAX(q2m_cor(i, nsrf), 0.)
     68        u10m_cor(i, nsrf) = SIGN(MIN(ABS(u1(i)), ABS(u10m(i, nsrf))), u1(i))
     69        v10m_cor(i, nsrf) = SIGN(MIN(ABS(v1(i)), ABS(v10m(i, nsrf))), v1(i))
     70      ELSEIF(iflag_bug_t2m_stab_ipslcm61==0) THEN
     71        t2m_cor(i, nsrf) = MIN(t2m(i, nsrf), MAX(t1(i), ftsol(i, nsrf)))
     72        t2m_cor(i, nsrf) = MAX(t2m_cor(i, nsrf), MIN(t1(i), ftsol(i, nsrf)))
     73        q2m_cor(i, nsrf) = MIN(q2m(i, nsrf), MAX(q1(i), qsurf(i)))
     74        q2m_cor(i, nsrf) = MAX(q2m_cor(i, nsrf), MIN(q1(i), qsurf(i)))
     75        q2m_cor(i, nsrf) = MAX(q2m_cor(i, nsrf), 0.)
     76        u10m_cor(i, nsrf) = SIGN(MIN(ABS(u1(i)), ABS(u10m(i, nsrf))), u1(i))
     77        v10m_cor(i, nsrf) = SIGN(MIN(ABS(v1(i)), ABS(v10m(i, nsrf))), v1(i))
     78      ENDIF
     79      !!!
     80      zdelta1 = MAX(0., SIGN(1., rtt - t2m_cor(i, nsrf)))
     81      zx_qs1 = r2es * FOEEW(t2m_cor(i, nsrf), zdelta1) / paprs(i, 1)
     82      zx_qs1 = MIN(0.5, zx_qs1)
     83      zcor1 = 1. / (1. - RETV * zx_qs1)
     84      zx_qs1 = zx_qs1 * zcor1
     85      zrh2m_cor(i) = zrh2m_cor(i) + q2m_cor(i, nsrf) / zx_qs1 * pctsrf(i, nsrf)
     86      zqsat2m_cor(i) = zqsat2m_cor(i) + zx_qs1 * pctsrf(i, nsrf)
     87      !!!
     88    ENDDO
     89  ENDDO
    9090
    91 !==================================================================
    92 ! Agregation of sub surfaces
    93 !==================================================================
     91  !==================================================================
     92  ! Agregation of sub surfaces
     93  !==================================================================
    9494
    95 zt2m_cor=0.
    96 zq2m_cor=0.
    97 zu10m_cor=0.
    98 zv10m_cor=0.
    99 DO nsrf = 1, nbsrf
    100    DO i = 1, klon
    101       zt2m_cor(i)  = zt2m_cor(i)  + t2m_cor(i,nsrf)  * pctsrf(i,nsrf)
    102       zq2m_cor(i)  = zq2m_cor(i)  + q2m_cor(i,nsrf)  * pctsrf(i,nsrf)
    103       zu10m_cor(i) = zu10m_cor(i) + u10m_cor(i,nsrf) * pctsrf(i,nsrf)
    104       zv10m_cor(i) = zv10m_cor(i) + v10m_cor(i,nsrf) * pctsrf(i,nsrf)
    105    ENDDO
    106 ENDDO
     95  zt2m_cor = 0.
     96  zq2m_cor = 0.
     97  zu10m_cor = 0.
     98  zv10m_cor = 0.
     99  DO nsrf = 1, nbsrf
     100    DO i = 1, klon
     101      zt2m_cor(i) = zt2m_cor(i) + t2m_cor(i, nsrf) * pctsrf(i, nsrf)
     102      zq2m_cor(i) = zq2m_cor(i) + q2m_cor(i, nsrf) * pctsrf(i, nsrf)
     103      zu10m_cor(i) = zu10m_cor(i) + u10m_cor(i, nsrf) * pctsrf(i, nsrf)
     104      zv10m_cor(i) = zv10m_cor(i) + v10m_cor(i, nsrf) * pctsrf(i, nsrf)
     105    ENDDO
     106  ENDDO
    107107
    108 RETURN
     108  RETURN
    109109END
    110110

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

    r5137 r5143  
    2020    USE sens_heat_rain_m, ONLY: sens_heat_rain
    2121    USE lmdz_clesphys
     22    USE lmdz_YOETHF
     23    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    2224
    2325! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
    … …  
    5961!   lat_prec_sol                                  precipitations solides
    6062
    61     INCLUDE "YOETHF.h"
    62     INCLUDE "FCTTRE.h"
    6363    INCLUDE "YOMCST.h"
    6464

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

    r5137 r5143  
    3030  USE lmdz_atke_turbulence_ini, ONLY: smmin, ric, cinf, cepsilon, pr_slope, pr_asym, pr_neut
    3131  USE lmdz_clesphys
     32  USE lmdz_YOETHF
    3233
    3334  IMPLICIT NONE
    … …  
    118119
    119120  INCLUDE "YOMCST.h"
    120   INCLUDE "YOETHF.h"
    121121
    122122

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

    r5137 r5143  
    1111  USE lmdz_abort_physic, ONLY: abort_physic
    1212  USE lmdz_clesphys
     13  USE lmdz_YOETHF
    1314
    1415  IMPLICIT NONE
    … …  
    4445
    4546  INCLUDE "YOMCST.h"
    46   INCLUDE "YOETHF.h"
    4747
    4848! Quelques constantes et options:

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

    r5139 r5143  
    1 
    21MODULE coef_diff_turb_mod
    32
    4 ! This module contains some procedures for calculation of the coefficients of the
    5 ! turbulent diffusion in the atmosphere and coefficients for turbulent diffusion
    6 ! at surface(cdrag)
     3  ! This module contains some procedures for calculation of the coefficients of the
     4  ! turbulent diffusion in the atmosphere and coefficients for turbulent diffusion
     5  ! at surface(cdrag)
    76
    87  IMPLICIT NONE
    9  
     8
    109CONTAINS
    1110
    12 !****************************************************************************************
     11  !****************************************************************************************
    1312
    1413  SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, &
    15        ypaprs, ypplay, yu, yv, yq, yt, yts, yqsurf, ycdragm, &
    16        ycoefm, ycoefh ,yq2, yeps, ydrgpro)
    17  
     14          ypaprs, ypplay, yu, yv, yq, yt, yts, yqsurf, ycdragm, &
     15          ycoefm, ycoefh, yq2, yeps, ydrgpro)
     16
    1817    USE dimphy
    1918    USE indice_sol_mod
    … …  
    2120    USE lmdz_clesphys
    2221    USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree
    23 
    24 ! Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the
    25 ! atmosphere
    26 ! NB! No values are calculated between surface and the first model layer.
    27 !     ycoefm(:,1) and ycoefh(:,1) are not valid !!!
    28 
    29 
    30 ! Input arguments
    31 !****************************************************************************************
    32     REAL, INTENT(IN)                           :: dtime
    33     INTEGER, INTENT(IN)                        :: nsrf, knon
    34     INTEGER, DIMENSION(klon), INTENT(IN)       :: ni
    35     REAL, DIMENSION(klon,klev+1), INTENT(IN)   :: ypaprs
    36     REAL, DIMENSION(klon,klev), INTENT(IN)     :: ypplay
    37     REAL, DIMENSION(klon,klev), INTENT(IN)     :: yu, yv
    38     REAL, DIMENSION(klon,klev), INTENT(IN)     :: yq, yt
    39     REAL, DIMENSION(klon), INTENT(IN)          :: yts, yqsurf
    40     REAL, DIMENSION(klon), INTENT(IN)          :: ycdragm
    41 !FC
    42     REAL, DIMENSION(klon,klev), INTENT(IN)     :: ydrgpro
    43 
    44 
    45 ! InOutput arguments
    46 !****************************************************************************************
    47     REAL, DIMENSION(klon,klev+1), INTENT(INOUT):: yq2
    48  
    49 ! Output arguments
    50 !****************************************************************************************
    51     REAL, DIMENSION(klon,klev+1), INTENT(OUT)  :: yeps
    52     REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefh
    53     REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefm
    54 
    55 ! Other local variables
    56 !****************************************************************************************
    57     INTEGER                                    :: k, i, j
    58     REAL, DIMENSION(klon,klev)                 :: ycoefm0, ycoefh0, yzlay, yteta
    59     REAL, DIMENSION(klon,klev+1)               :: yzlev, q2diag, ykmm, ykmn, ykmq
    60     REAL, DIMENSION(klon)                      :: yustar
    61 
    62 ! Include
    63 !****************************************************************************************
    64     INCLUDE "YOETHF.h"
     22    USE lmdz_YOETHF
     23
     24    ! Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the
     25    ! atmosphere
     26    ! NB! No values are calculated between surface and the first model layer.
     27    !     ycoefm(:,1) and ycoefh(:,1) are not valid !!!
     28
     29
     30    ! Input arguments
     31    !****************************************************************************************
     32    REAL, INTENT(IN) :: dtime
     33    INTEGER, INTENT(IN) :: nsrf, knon
     34    INTEGER, DIMENSION(klon), INTENT(IN) :: ni
     35    REAL, DIMENSION(klon, klev + 1), INTENT(IN) :: ypaprs
     36    REAL, DIMENSION(klon, klev), INTENT(IN) :: ypplay
     37    REAL, DIMENSION(klon, klev), INTENT(IN) :: yu, yv
     38    REAL, DIMENSION(klon, klev), INTENT(IN) :: yq, yt
     39    REAL, DIMENSION(klon), INTENT(IN) :: yts, yqsurf
     40    REAL, DIMENSION(klon), INTENT(IN) :: ycdragm
     41    !FC
     42    REAL, DIMENSION(klon, klev), INTENT(IN) :: ydrgpro
     43
     44
     45    ! InOutput arguments
     46    !****************************************************************************************
     47    REAL, DIMENSION(klon, klev + 1), INTENT(INOUT) :: yq2
     48
     49    ! Output arguments
     50    !****************************************************************************************
     51    REAL, DIMENSION(klon, klev + 1), INTENT(OUT) :: yeps
     52    REAL, DIMENSION(klon, klev), INTENT(OUT) :: ycoefh
     53    REAL, DIMENSION(klon, klev), INTENT(OUT) :: ycoefm
     54
     55    ! Other local variables
     56    !****************************************************************************************
     57    INTEGER :: k, i, j
     58    REAL, DIMENSION(klon, klev) :: ycoefm0, ycoefh0, yzlay, yteta
     59    REAL, DIMENSION(klon, klev + 1) :: yzlev, q2diag, ykmm, ykmn, ykmq
     60    REAL, DIMENSION(klon) :: yustar
     61
     62    ! Include
     63    !****************************************************************************************
    6564    INCLUDE "YOMCST.h"
    66 
    6765
    6866    ykmm = 0 !ym missing init
    6967    ykmn = 0 !ym missing init
    7068    ykmq = 0 !ym missing init
    71    
    72     yeps(:,:) = 0.
    73 
    74 !****************************************************************************************   
    75 ! Calcul de coefficients de diffusion turbulent de l'atmosphere :
    76 ! ycoefm(:,2:klev), ycoefh(:,2:klev)
    77 
    78 !****************************************************************************************   
     69
     70    yeps(:, :) = 0.
     71
     72    !****************************************************************************************
     73    ! Calcul de coefficients de diffusion turbulent de l'atmosphere :
     74    ! ycoefm(:,2:klev), ycoefh(:,2:klev)
     75
     76    !****************************************************************************************
    7977
    8078    CALL coefkz(nsrf, knon, ypaprs, ypplay, &
    81          ksta, ksta_ter, &
    82          yts, yu, yv, yt, yq, &
    83          yqsurf, &
    84          ycoefm, ycoefh)
    85  
    86 !****************************************************************************************
    87 ! Eventuelle recalcule des coeffeicients de diffusion turbulent de l'atmosphere :
    88 ! ycoefm(:,2:klev), ycoefh(:,2:klev)
    89 
    90 !****************************************************************************************
     79            ksta, ksta_ter, &
     80            yts, yu, yv, yt, yq, &
     81            yqsurf, &
     82            ycoefm, ycoefh)
     83
     84    !****************************************************************************************
     85    ! Eventuelle recalcule des coeffeicients de diffusion turbulent de l'atmosphere :
     86    ! ycoefm(:,2:klev), ycoefh(:,2:klev)
     87
     88    !****************************************************************************************
    9189
    9290    IF (iflag_pbl==1) THEN
    93        CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, &
    94             ycoefm0, ycoefh0)
    95 
    96        DO k = 2, klev
    97           DO i = 1, knon
    98              ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
    99              ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
    100           ENDDO
    101        ENDDO
     91      CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, &
     92              ycoefm0, ycoefh0)
     93
     94      DO k = 2, klev
     95        DO i = 1, knon
     96          ycoefm(i, k) = MAX(ycoefm(i, k), ycoefm0(i, k))
     97          ycoefh(i, k) = MAX(ycoefh(i, k), ycoefh0(i, k))
     98        ENDDO
     99      ENDDO
    102100    ENDIF
    103101
    104  
    105 !**************************************************************************************** 
    106 ! Calcul d'une diffusion minimale pour les conditions tres stables
    107 
    108 !****************************************************************************************
     102
     103    !****************************************************************************************
     104    ! Calcul d'une diffusion minimale pour les conditions tres stables
     105
     106    !****************************************************************************************
    109107    IF (ok_kzmin) THEN
    110        CALL coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycdragm, &
    111             ycoefm0,ycoefh0)
    112        
    113        DO k = 2, klev
    114           DO i = 1, knon
    115              ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
    116              ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
    117           ENDDO
    118        ENDDO
    119        
     108      CALL coefkzmin(knon, ypaprs, ypplay, yu, yv, yt, yq, ycdragm, &
     109              ycoefm0, ycoefh0)
     110
     111      DO k = 2, klev
     112        DO i = 1, knon
     113          ycoefm(i, k) = MAX(ycoefm(i, k), ycoefm0(i, k))
     114          ycoefh(i, k) = MAX(ycoefh(i, k), ycoefh0(i, k))
     115        ENDDO
     116      ENDDO
     117
    120118    ENDIF
    121119
    122  
    123 !****************************************************************************************
    124 ! MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin
    125 
    126 !****************************************************************************************
     120
     121    !****************************************************************************************
     122    ! MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin
     123
     124    !****************************************************************************************
    127125
    128126    IF (iflag_pbl>=3) THEN
    129127
    130        yzlay(1:knon,1)= &
    131             RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) &
    132             *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
    133        DO k=2,klev
    134           DO i = 1, knon
    135              yzlay(i,k)= &
    136                   yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) &
    137                   /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
    138           END DO
    139        END DO
    140 
    141        DO k=1,klev
    142           DO i = 1, knon
    143              yteta(i,k)= &
    144                   yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**RKAPPA &
    145                   *(1.+0.61*yq(i,k))
    146           END DO
    147        END DO
    148 
    149        yzlev(1:knon,1)=0.
    150        yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1)
    151        DO k=2,klev
    152           DO i = 1, knon
    153              yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
    154           END DO
    155        END DO
    156 
    157 !!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    158 !!$! Pour memoire, le papier Hourdin et al. 2002 a ete obtenur avec un
    159 !!$! bug sur les coefficients de surface :
    160 !!$!          ycdragh(1:knon) = ycoefm(1:knon,1)
    161 !!$!          ycdragm(1:knon) = ycoefh(1:knon,1)
    162 !!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    163 
    164        ! Normalement, on peut passer dans les codes avec knon=0
    165        ! Mais ca fait planter le replay.
    166        ! En attendant une réécriture, on a joute des if (Fredho)
    167        IF ( klon>1 .OR. (klon==1 .AND. knon==1) ) THEN
    168           CALL ustarhb(knon,klev,knon,yu,yv,ycdragm, yustar)
    169        endif
    170      
    171        IF (prt_level > 9) THEN
    172           WRITE(lunout,*) 'USTAR = ',(yustar(i),i=1,knon)
    173        ENDIF
    174          
    175 !   iflag_pbl peut etre utilise comme longuer de melange
    176        IF (iflag_pbl>=31) THEN
    177           IF ( klon>1 .OR. (klon==1 .AND. knon==1) ) THEN
    178           CALL vdif_kcay(knon,klev,knon,dtime,RG,RD,ypaprs,yt, &
    179                yzlev,yzlay,yu,yv,yteta, &
    180                ycdragm,yq2,q2diag,ykmm,ykmn,yustar, &
    181                iflag_pbl)
    182           endif
    183        ELSE IF (iflag_pbl<20) THEN
    184           CALL yamada4(ni,nsrf,knon,dtime,RG,RD,ypaprs,yt, &
    185                yzlev,yzlay,yu,yv,yteta, &
    186                ycdragm,yq2,yeps,ykmm,ykmn,ykmq,yustar, &
    187                iflag_pbl,ydrgpro)
    188 !FC
    189        ENDIF
    190        
    191        ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev)
    192        ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev)
    193                
     128      yzlay(1:knon, 1) = &
     129              RD * yt(1:knon, 1) / (0.5 * (ypaprs(1:knon, 1) + ypplay(1:knon, 1))) &
     130                      * (ypaprs(1:knon, 1) - ypplay(1:knon, 1)) / RG
     131      DO k = 2, klev
     132        DO i = 1, knon
     133          yzlay(i, k) = &
     134                  yzlay(i, k - 1) + RD * 0.5 * (yt(i, k - 1) + yt(i, k)) &
     135                          / ypaprs(i, k) * (ypplay(i, k - 1) - ypplay(i, k)) / RG
     136        END DO
     137      END DO
     138
     139      DO k = 1, klev
     140        DO i = 1, knon
     141          yteta(i, k) = &
     142                  yt(i, k) * (ypaprs(i, 1) / ypplay(i, k))**RKAPPA &
     143                          * (1. + 0.61 * yq(i, k))
     144        END DO
     145      END DO
     146
     147      yzlev(1:knon, 1) = 0.
     148      yzlev(1:knon, klev + 1) = 2. * yzlay(1:knon, klev) - yzlay(1:knon, klev - 1)
     149      DO k = 2, klev
     150        DO i = 1, knon
     151          yzlev(i, k) = 0.5 * (yzlay(i, k) + yzlay(i, k - 1))
     152        END DO
     153      END DO
     154
     155      !!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     156      !!$! Pour memoire, le papier Hourdin et al. 2002 a ete obtenur avec un
     157      !!$! bug sur les coefficients de surface :
     158      !!$!          ycdragh(1:knon) = ycoefm(1:knon,1)
     159      !!$!          ycdragm(1:knon) = ycoefh(1:knon,1)
     160      !!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     161
     162      ! Normalement, on peut passer dans les codes avec knon=0
     163      ! Mais ca fait planter le replay.
     164      ! En attendant une réécriture, on a joute des if (Fredho)
     165      IF (klon>1 .OR. (klon==1 .AND. knon==1)) THEN
     166        CALL ustarhb(knon, klev, knon, yu, yv, ycdragm, yustar)
     167      endif
     168
     169      IF (prt_level > 9) THEN
     170        WRITE(lunout, *) 'USTAR = ', (yustar(i), i = 1, knon)
     171      ENDIF
     172
     173      !   iflag_pbl peut etre utilise comme longuer de melange
     174      IF (iflag_pbl>=31) THEN
     175        IF (klon>1 .OR. (klon==1 .AND. knon==1)) THEN
     176          CALL vdif_kcay(knon, klev, knon, dtime, RG, RD, ypaprs, yt, &
     177                  yzlev, yzlay, yu, yv, yteta, &
     178                  ycdragm, yq2, q2diag, ykmm, ykmn, yustar, &
     179                  iflag_pbl)
     180        endif
     181      ELSE IF (iflag_pbl<20) THEN
     182        CALL yamada4(ni, nsrf, knon, dtime, RG, RD, ypaprs, yt, &
     183                yzlev, yzlay, yu, yv, yteta, &
     184                ycdragm, yq2, yeps, ykmm, ykmn, ykmq, yustar, &
     185                iflag_pbl, ydrgpro)
     186        !FC
     187      ENDIF
     188
     189      ycoefm(1:knon, 2:klev) = ykmm(1:knon, 2:klev)
     190      ycoefh(1:knon, 2:klev) = ykmn(1:knon, 2:klev)
     191
    194192    ELSE
    195        ! No TKE for Standard Physics
    196        yq2=0.
     193      ! No TKE for Standard Physics
     194      yq2 = 0.
    197195    ENDIF !(iflag_pbl.ge.3)
    198196
    199197  END SUBROUTINE coef_diff_turb
    200198
    201 !****************************************************************************************
     199  !****************************************************************************************
    202200
    203201  SUBROUTINE coefkz(nsrf, knon, paprs, pplay, &
    204        ksta, ksta_ter, &
    205        ts, &
    206        u,v,t,q, &
    207        qsurf, &
    208        pcfm, pcfh)
    209    
     202          ksta, ksta_ter, &
     203          ts, &
     204          u, v, t, q, &
     205          qsurf, &
     206          pcfm, pcfh)
     207
    210208    USE dimphy
    211209    USE indice_sol_mod
    212210    USE lmdz_print_control, ONLY: prt_level, lunout
    213211    USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree
    214  
    215 !======================================================================
    216 ! Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922
    217 !           (une version strictement identique a l'ancien modele)
    218 ! Objet: calculer le coefficient du frottement du sol (Cdrag) et les
    219 !        coefficients d'echange turbulent dans l'atmosphere.
    220 ! Arguments:
    221 ! nsrf-----input-I- indicateur de la nature du sol
    222 ! knon-----input-I- nombre de points a traiter
    223 ! paprs----input-R- pregssion a chaque intercouche (en Pa)
    224 ! pplay----input-R- pression au milieu de chaque couche (en Pa)
    225 ! ts-------input-R- temperature du sol (en Kelvin)
    226 ! u--------input-R- vitesse u
    227 ! v--------input-R- vitesse v
    228 ! t--------input-R- temperature (K)
    229 ! q--------input-R- vapeur d'eau (kg/kg)
    230 
    231 ! pcfm-----output-R- coefficients a calculer (vitesse)
    232 ! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
    233 !======================================================================
    234     INCLUDE "YOETHF.h"
     212    USE lmdz_YOETHF
     213    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     214
     215    !======================================================================
     216    ! Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922
     217    !           (une version strictement identique a l'ancien modele)
     218    ! Objet: calculer le coefficient du frottement du sol (Cdrag) et les
     219    !        coefficients d'echange turbulent dans l'atmosphere.
     220    ! Arguments:
     221    ! nsrf-----input-I- indicateur de la nature du sol
     222    ! knon-----input-I- nombre de points a traiter
     223    ! paprs----input-R- pregssion a chaque intercouche (en Pa)
     224    ! pplay----input-R- pression au milieu de chaque couche (en Pa)
     225    ! ts-------input-R- temperature du sol (en Kelvin)
     226    ! u--------input-R- vitesse u
     227    ! v--------input-R- vitesse v
     228    ! t--------input-R- temperature (K)
     229    ! q--------input-R- vapeur d'eau (kg/kg)
     230
     231    ! pcfm-----output-R- coefficients a calculer (vitesse)
     232    ! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
     233    !======================================================================
    235234    INCLUDE "YOMCST.h"
    236     INCLUDE "FCTTRE.h"
    237 
    238 ! Arguments:
    239 
    240     INTEGER, INTENT(IN)                      :: knon, nsrf
    241     REAL, INTENT(IN)                         :: ksta, ksta_ter
    242     REAL, DIMENSION(klon), INTENT(IN)        :: ts
    243     REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
    244     REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
    245     REAL, DIMENSION(klon,klev), INTENT(IN)   :: u, v, t, q
    246     REAL, DIMENSION(klon), INTENT(IN)        :: qsurf
    247 
    248     REAL, DIMENSION(klon,klev), INTENT(OUT)  :: pcfm, pcfh
    249 
    250 ! Local variables:
    251 
    252     INTEGER, DIMENSION(klon)    :: itop ! numero de couche du sommet de la couche limite
    253 
    254 ! Quelques constantes et options:
    255 
    256     REAL, PARAMETER :: cepdu2=0.1**2
    257     REAL, PARAMETER :: CKAP=0.4
    258     REAL, PARAMETER :: cb=5.0
    259     REAL, PARAMETER :: cc=5.0
    260     REAL, PARAMETER :: cd=5.0
    261     REAL, PARAMETER :: clam=160.0
    262     REAL, PARAMETER :: ratqs=0.05 ! largeur de distribution de vapeur d'eau
    263     LOGICAL, PARAMETER :: richum=.TRUE. ! utilise le nombre de Richardson humide
    264     REAL, PARAMETER :: ric=0.4 ! nombre de Richardson critique
    265     REAL, PARAMETER :: prandtl=0.4
     235
     236    ! Arguments:
     237
     238    INTEGER, INTENT(IN) :: knon, nsrf
     239    REAL, INTENT(IN) :: ksta, ksta_ter
     240    REAL, DIMENSION(klon), INTENT(IN) :: ts
     241    REAL, DIMENSION(klon, klev + 1), INTENT(IN) :: paprs
     242    REAL, DIMENSION(klon, klev), INTENT(IN) :: pplay
     243    REAL, DIMENSION(klon, klev), INTENT(IN) :: u, v, t, q
     244    REAL, DIMENSION(klon), INTENT(IN) :: qsurf
     245
     246    REAL, DIMENSION(klon, klev), INTENT(OUT) :: pcfm, pcfh
     247
     248    ! Local variables:
     249
     250    INTEGER, DIMENSION(klon) :: itop ! numero de couche du sommet de la couche limite
     251
     252    ! Quelques constantes et options:
     253
     254    REAL, PARAMETER :: cepdu2 = 0.1**2
     255    REAL, PARAMETER :: CKAP = 0.4
     256    REAL, PARAMETER :: cb = 5.0
     257    REAL, PARAMETER :: cc = 5.0
     258    REAL, PARAMETER :: cd = 5.0
     259    REAL, PARAMETER :: clam = 160.0
     260    REAL, PARAMETER :: ratqs = 0.05 ! largeur de distribution de vapeur d'eau
     261    LOGICAL, PARAMETER :: richum = .TRUE. ! utilise le nombre de Richardson humide
     262    REAL, PARAMETER :: ric = 0.4 ! nombre de Richardson critique
     263    REAL, PARAMETER :: prandtl = 0.4
    266264    REAL kstable ! diffusion minimale (situation stable)
    267265    ! GKtest
    268266    ! PARAMETER (kstable=1.0e-10)
    269 !IM: 261103     REAL kstable_ter, kstable_sinon
    270 !IM: 211003 cf GK   PARAMETER (kstable_ter = 1.0e-6)
    271 !IM: 261103     PARAMETER (kstable_ter = 1.0e-8)
    272 !IM: 261103   PARAMETER (kstable_ter = 1.0e-10)
    273 !IM: 261103   PARAMETER (kstable_sinon = 1.0e-10)
     267    !IM: 261103     REAL kstable_ter, kstable_sinon
     268    !IM: 211003 cf GK   PARAMETER (kstable_ter = 1.0e-6)
     269    !IM: 261103     PARAMETER (kstable_ter = 1.0e-8)
     270    !IM: 261103   PARAMETER (kstable_ter = 1.0e-10)
     271    !IM: 261103   PARAMETER (kstable_sinon = 1.0e-10)
    274272    ! fin GKtest
    275     REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange
     273    REAL, PARAMETER :: mixlen = 35.0 ! constante controlant longueur de melange
    276274    INTEGER isommet ! le sommet de la couche limite
    277     LOGICAL, PARAMETER :: tvirtu=.TRUE. ! calculer Ri d'une maniere plus performante
    278     LOGICAL, PARAMETER :: opt_ec=.FALSE.! formule du Centre Europeen dans l'atmosphere
    279 
    280 ! Variables locales:
     275    LOGICAL, PARAMETER :: tvirtu = .TRUE. ! calculer Ri d'une maniere plus performante
     276    LOGICAL, PARAMETER :: opt_ec = .FALSE.! formule du Centre Europeen dans l'atmosphere
     277
     278    ! Variables locales:
    281279    INTEGER i, k !IM 120704
    282     REAL zgeop(klon,klev)
     280    REAL zgeop(klon, klev)
    283281    REAL zmgeom(klon)
    284282    REAL zri(klon)
    … …  
    288286    REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs
    289287    REAL z2geomf, zalh2, zalm2, zscfh, zscfm
    290     REAL, PARAMETER :: t_coup=273.15
    291     LOGICAL, PARAMETER :: check=.FALSE.
    292 
    293 ! contre-gradient pour la chaleur sensible: Kelvin/metre
     288    REAL, PARAMETER :: t_coup = 273.15
     289    LOGICAL, PARAMETER :: check = .FALSE.
     290
     291    ! contre-gradient pour la chaleur sensible: Kelvin/metre
    294292    REAL gamt(2:klev)
    295293
    296     LOGICAL, SAVE :: appel1er=.TRUE.
     294    LOGICAL, SAVE :: appel1er = .TRUE.
    297295    !$OMP THREADPRIVATE(appel1er)
    298296
    299 ! Fonctions thermodynamiques et fonctions d'instabilite
     297    ! Fonctions thermodynamiques et fonctions d'instabilite
    300298    REAL fsta, fins, x
    301299
    302     fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
    303     fins(x) = SQRT(1.0-18.0*x)
    304 
    305     isommet=klev
    306      
     300    fsta(x) = 1.0 / (1.0 + 10.0 * x * (1 + 8.0 * x))
     301    fins(x) = SQRT(1.0 - 18.0 * x)
     302
     303    isommet = klev
     304
    307305    IF (appel1er) THEN
    308        IF (prt_level > 9) THEN
    309           WRITE(lunout,*)'coefkz, opt_ec:', opt_ec
    310           WRITE(lunout,*)'coefkz, richum:', richum
    311           IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs
    312           WRITE(lunout,*)'coefkz, isommet:', isommet
    313           WRITE(lunout,*)'coefkz, tvirtu:', tvirtu
    314           appel1er = .FALSE.
    315        ENDIF
     306      IF (prt_level > 9) THEN
     307        WRITE(lunout, *)'coefkz, opt_ec:', opt_ec
     308        WRITE(lunout, *)'coefkz, richum:', richum
     309        IF (richum) WRITE(lunout, *)'coefkz, ratqs:', ratqs
     310        WRITE(lunout, *)'coefkz, isommet:', isommet
     311        WRITE(lunout, *)'coefkz, tvirtu:', tvirtu
     312        appel1er = .FALSE.
     313      ENDIF
    316314    ENDIF
    317315
    318 ! Initialiser les sorties
     316    ! Initialiser les sorties
    319317
    320318    DO k = 1, klev
    321        DO i = 1, knon
    322           pcfm(i,k) = 0.0
    323           pcfh(i,k) = 0.0
    324        ENDDO
     319      DO i = 1, knon
     320        pcfm(i, k) = 0.0
     321        pcfh(i, k) = 0.0
     322      ENDDO
    325323    ENDDO
    326324    DO i = 1, knon
    327        itop(i) = 0
    328     ENDDO
    329 
    330 ! Prescrire la valeur de contre-gradient
     325      itop(i) = 0
     326    ENDDO
     327
     328    ! Prescrire la valeur de contre-gradient
    331329
    332330    IF (iflag_pbl==1) THEN
    333        DO k = 3, klev
    334           gamt(k) = -1.0E-03
    335        ENDDO
    336        gamt(2) = -2.5E-03
     331      DO k = 3, klev
     332        gamt(k) = -1.0E-03
     333      ENDDO
     334      gamt(2) = -2.5E-03
    337335    ELSE
    338        DO k = 2, klev
    339           gamt(k) = 0.0
    340        ENDDO
     336      DO k = 2, klev
     337        gamt(k) = 0.0
     338      ENDDO
    341339    ENDIF
    342 !IM cf JLD/ GKtest
    343     IF ( nsrf /= is_oce ) THEN
    344 !IM 261103     kstable = kstable_ter
    345        kstable = ksta_ter
     340    !IM cf JLD/ GKtest
     341    IF (nsrf /= is_oce) THEN
     342      !IM 261103     kstable = kstable_ter
     343      kstable = ksta_ter
    346344    ELSE
    347 !IM 261103     kstable = kstable_sinon
    348        kstable = ksta
     345      !IM 261103     kstable = kstable_sinon
     346      kstable = ksta
    349347    ENDIF
    350 !IM cf JLD/ GKtest fin
    351 
    352 ! Calculer les geopotentiels de chaque couche
     348    !IM cf JLD/ GKtest fin
     349
     350    ! Calculer les geopotentiels de chaque couche
    353351
    354352    DO i = 1, knon
    355        zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) &
    356             * (paprs(i,1)-pplay(i,1))
     353      zgeop(i, 1) = RD * t(i, 1) / (0.5 * (paprs(i, 1) + pplay(i, 1))) &
     354              * (paprs(i, 1) - pplay(i, 1))
    357355    ENDDO
    358356    DO k = 2, klev
    359        DO i = 1, knon
    360           zgeop(i,k) = zgeop(i,k-1) &
    361                + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) &
    362                * (pplay(i,k-1)-pplay(i,k))
    363        ENDDO
    364     ENDDO
    365 
    366 ! Calculer les coefficients turbulents dans l'atmosphere
     357      DO i = 1, knon
     358        zgeop(i, k) = zgeop(i, k - 1) &
     359                + RD * 0.5 * (t(i, k - 1) + t(i, k)) / paprs(i, k) &
     360                        * (pplay(i, k - 1) - pplay(i, k))
     361      ENDDO
     362    ENDDO
     363
     364    ! Calculer les coefficients turbulents dans l'atmosphere
    367365
    368366    DO i = 1, knon
    369        itop(i) = isommet
    370     ENDDO
    371 
     367      itop(i) = isommet
     368    ENDDO
    372369
    373370    DO k = 2, isommet
    374        DO i = 1, knon
    375           zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2 &
    376                +(v(i,k)-v(i,k-1))**2)
    377           zmgeom(i)=zgeop(i,k)-zgeop(i,k-1)
    378           zdphi =zmgeom(i) / 2.0
    379           zt = (t(i,k)+t(i,k-1)) * 0.5
    380           zq = (q(i,k)+q(i,k-1)) * 0.5
    381 
    382 ! Calculer Qs et dQs/dT:
    383 
    384           IF (thermcep) THEN
    385              zdelta = MAX(0.,SIGN(1.,RTT-zt))
    386              zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) &
    387                   + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta
    388              zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k)
    389              zqs = MIN(0.5,zqs)
    390              zcor = 1./(1.-RETV*zqs)
    391              zqs = zqs*zcor
    392              zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor)
     371      DO i = 1, knon
     372        zdu2 = MAX(cepdu2, (u(i, k) - u(i, k - 1))**2 &
     373                + (v(i, k) - v(i, k - 1))**2)
     374        zmgeom(i) = zgeop(i, k) - zgeop(i, k - 1)
     375        zdphi = zmgeom(i) / 2.0
     376        zt = (t(i, k) + t(i, k - 1)) * 0.5
     377        zq = (q(i, k) + q(i, k - 1)) * 0.5
     378
     379        ! Calculer Qs et dQs/dT:
     380
     381        IF (thermcep) THEN
     382          zdelta = MAX(0., SIGN(1., RTT - zt))
     383          zcvm5 = R5LES * RLVTT / RCPD / (1.0 + RVTMP2 * zq) * (1. - zdelta) &
     384                  + R5IES * RLSTT / RCPD / (1.0 + RVTMP2 * zq) * zdelta
     385          zqs = R2ES * FOEEW(zt, zdelta) / pplay(i, k)
     386          zqs = MIN(0.5, zqs)
     387          zcor = 1. / (1. - RETV * zqs)
     388          zqs = zqs * zcor
     389          zdqs = FOEDE(zt, zdelta, zcvm5, zqs, zcor)
     390        ELSE
     391          IF (zt < t_coup) THEN
     392            zqs = qsats(zt) / pplay(i, k)
     393            zdqs = dqsats(zt, zqs)
    393394          ELSE
    394              IF (zt < t_coup) THEN
    395                 zqs = qsats(zt) / pplay(i,k)
    396                 zdqs = dqsats(zt,zqs)
    397              ELSE
    398                 zqs = qsatl(zt) / pplay(i,k)
    399                 zdqs = dqsatl(zt,zqs)
    400              ENDIF
     395            zqs = qsatl(zt) / pplay(i, k)
     396            zdqs = dqsatl(zt, zqs)
    401397          ENDIF
    402 
    403 !           calculer la fraction nuageuse (processus humide):
    404 
    405           IF (zq /= 0.) THEN
    406              zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq)
    407           else
    408              zfr = 0.
    409           end if
    410           zfr = MAX(0.0,MIN(1.0,zfr))
    411           IF (.NOT.richum) zfr = 0.0
    412 
    413 !           calculer le nombre de Richardson:
    414 
    415           IF (tvirtu) THEN
    416              ztvd =( t(i,k) &
    417                   + zdphi/RCPD/(1.+RVTMP2*zq) &
    418                   *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
    419                   )*(1.+RETV*q(i,k))
    420              ztvu =( t(i,k-1) &
    421                   - zdphi/RCPD/(1.+RVTMP2*zq) &
    422                   *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
    423                   )*(1.+RETV*q(i,k-1))
    424              zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
    425              zri(i) = zri(i) &
    426                   + zmgeom(i)*zmgeom(i)/RG*gamt(k) &
    427                   *(paprs(i,k)/101325.0)**RKAPPA &
    428                   /(zdu2*0.5*(ztvd+ztvu))
    429 
    430           ELSE ! calcul de Ridchardson compatible LMD5
    431 
    432              zri(i) =(RCPD*(t(i,k)-t(i,k-1)) &
    433                   -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k) &
    434                   *(pplay(i,k)-pplay(i,k-1)) &
    435                   )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k)))
    436              zri(i) = zri(i) + &
    437                   zmgeom(i)*zmgeom(i)*gamt(k)/RG &
    438                   *(paprs(i,k)/101325.0)**RKAPPA &
    439                   /(zdu2*0.5*(t(i,k-1)+t(i,k)))
     398        ENDIF
     399
     400        !           calculer la fraction nuageuse (processus humide):
     401
     402        IF (zq /= 0.) THEN
     403          zfr = (zq + ratqs * zq - zqs) / (2.0 * ratqs * zq)
     404        else
     405          zfr = 0.
     406        end if
     407        zfr = MAX(0.0, MIN(1.0, zfr))
     408        IF (.NOT.richum) zfr = 0.0
     409
     410        !           calculer le nombre de Richardson:
     411
     412        IF (tvirtu) THEN
     413          ztvd = (t(i, k) &
     414                  + zdphi / RCPD / (1. + RVTMP2 * zq) &
     415                          * ((1. - zfr) + zfr * (1. + RLVTT * zqs / RD / zt) / (1. + zdqs)) &
     416                  ) * (1. + RETV * q(i, k))
     417          ztvu = (t(i, k - 1) &
     418                  - zdphi / RCPD / (1. + RVTMP2 * zq) &
     419                          * ((1. - zfr) + zfr * (1. + RLVTT * zqs / RD / zt) / (1. + zdqs)) &
     420                  ) * (1. + RETV * q(i, k - 1))
     421          zri(i) = zmgeom(i) * (ztvd - ztvu) / (zdu2 * 0.5 * (ztvd + ztvu))
     422          zri(i) = zri(i) &
     423                  + zmgeom(i) * zmgeom(i) / RG * gamt(k) &
     424                          * (paprs(i, k) / 101325.0)**RKAPPA &
     425                          / (zdu2 * 0.5 * (ztvd + ztvu))
     426
     427        ELSE ! calcul de Ridchardson compatible LMD5
     428
     429          zri(i) = (RCPD * (t(i, k) - t(i, k - 1)) &
     430                  - RD * 0.5 * (t(i, k) + t(i, k - 1)) / paprs(i, k) &
     431                          * (pplay(i, k) - pplay(i, k - 1)) &
     432                  ) * zmgeom(i) / (zdu2 * 0.5 * RCPD * (t(i, k - 1) + t(i, k)))
     433          zri(i) = zri(i) + &
     434                  zmgeom(i) * zmgeom(i) * gamt(k) / RG &
     435                          * (paprs(i, k) / 101325.0)**RKAPPA &
     436                          / (zdu2 * 0.5 * (t(i, k - 1) + t(i, k)))
     437        ENDIF
     438
     439        !           finalement, les coefficients d'echange sont obtenus:
     440
     441        zcdn = SQRT(zdu2) / zmgeom(i) * RG
     442
     443        IF (opt_ec) THEN
     444          z2geomf = zgeop(i, k - 1) + zgeop(i, k)
     445          zalm2 = (0.5 * ckap / RG * z2geomf &
     446                  / (1. + 0.5 * ckap / rg / clam * z2geomf))**2
     447          zalh2 = (0.5 * ckap / rg * z2geomf &
     448                  / (1. + 0.5 * ckap / RG / (clam * SQRT(1.5 * cd)) * z2geomf))**2
     449          IF (zri(i)<0.0) THEN  ! situation instable
     450            zscf = ((zgeop(i, k) / zgeop(i, k - 1))**(1. / 3.) - 1.)**3 &
     451                    / (zmgeom(i) / RG)**3 / (zgeop(i, k - 1) / RG)
     452            zscf = SQRT(-zri(i) * zscf)
     453            zscfm = 1.0 / (1.0 + 3.0 * cb * cc * zalm2 * zscf)
     454            zscfh = 1.0 / (1.0 + 3.0 * cb * cc * zalh2 * zscf)
     455            pcfm(i, k) = zcdn * zalm2 * (1. - 2.0 * cb * zri(i) * zscfm)
     456            pcfh(i, k) = zcdn * zalh2 * (1. - 3.0 * cb * zri(i) * zscfh)
     457          ELSE ! situation stable
     458            zscf = SQRT(1. + cd * zri(i))
     459            pcfm(i, k) = zcdn * zalm2 / (1. + 2.0 * cb * zri(i) / zscf)
     460            pcfh(i, k) = zcdn * zalh2 / (1. + 3.0 * cb * zri(i) * zscf)
    440461          ENDIF
    441 
    442 !           finalement, les coefficients d'echange sont obtenus:
    443 
    444           zcdn=SQRT(zdu2) / zmgeom(i) * RG
    445 
    446           IF (opt_ec) THEN
    447              z2geomf=zgeop(i,k-1)+zgeop(i,k)
    448              zalm2=(0.5*ckap/RG*z2geomf &
    449                   /(1.+0.5*ckap/rg/clam*z2geomf))**2
    450              zalh2=(0.5*ckap/rg*z2geomf &
    451                   /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2
    452              IF (zri(i)<0.0) THEN  ! situation instable
    453                 zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3 &
    454                      / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG)
    455                 zscf = SQRT(-zri(i)*zscf)
    456                 zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf)
    457                 zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf)
    458                 pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm)
    459                 pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh)
    460              ELSE ! situation stable
    461                 zscf=SQRT(1.+cd*zri(i))
    462                 pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf)
    463                 pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf)
    464              ENDIF
    465           ELSE
    466              zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1)) &
    467                   /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2
    468              pcfm(i,k)=SQRT(MAX(zcdn*zcdn*(ric-zri(i))/ric, kstable))
    469              pcfm(i,k)= zl2(i)* pcfm(i,k)
    470              pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
    471           ENDIF
    472        ENDDO
    473     ENDDO
    474 
    475 ! Au-dela du sommet, pas de diffusion turbulente:
     462        ELSE
     463          zl2(i) = (mixlen * MAX(0.0, (paprs(i, k) - paprs(i, itop(i) + 1)) &
     464                  / (paprs(i, 2) - paprs(i, itop(i) + 1))))**2
     465          pcfm(i, k) = SQRT(MAX(zcdn * zcdn * (ric - zri(i)) / ric, kstable))
     466          pcfm(i, k) = zl2(i) * pcfm(i, k)
     467          pcfh(i, k) = pcfm(i, k) / prandtl ! h et m different
     468        ENDIF
     469      ENDDO
     470    ENDDO
     471
     472    ! Au-dela du sommet, pas de diffusion turbulente:
    476473
    477474    DO i = 1, knon
    478        IF (itop(i)+1 <= klev) THEN
    479           DO k = itop(i)+1, klev
    480              pcfh(i,k) = 0.0
    481              pcfm(i,k) = 0.0
    482           ENDDO
    483        ENDIF
    484     ENDDO
    485      
     475      IF (itop(i) + 1 <= klev) THEN
     476        DO k = itop(i) + 1, klev
     477          pcfh(i, k) = 0.0
     478          pcfm(i, k) = 0.0
     479        ENDDO
     480      ENDIF
     481    ENDDO
     482
    486483  END SUBROUTINE coefkz
    487484
    488 !****************************************************************************************
    489 
    490   SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t, &
    491        pcfm, pcfh)
     485  !****************************************************************************************
     486
     487  SUBROUTINE coefkz2(nsrf, knon, paprs, pplay, t, &
     488          pcfm, pcfh)
    492489
    493490    USE dimphy
    494491    USE indice_sol_mod
    495492
    496 !======================================================================
    497 ! J'introduit un peu de diffusion sauf dans les endroits
    498 ! ou une forte inversion est presente
    499 ! On peut dire qu'il represente la convection peu profonde
    500 
    501 ! Arguments:
    502 ! nsrf-----input-I- indicateur de la nature du sol
    503 ! knon-----input-I- nombre de points a traiter
    504 ! paprs----input-R- pression a chaque intercouche (en Pa)
    505 ! pplay----input-R- pression au milieu de chaque couche (en Pa)
    506 ! t--------input-R- temperature (K)
    507 
    508 ! pcfm-----output-R- coefficients a calculer (vitesse)
    509 ! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
    510 !======================================================================
    511 
    512 ! Arguments:
    513 
    514     INTEGER, INTENT(IN)                       :: knon, nsrf
    515     REAL, DIMENSION(klon, klev+1), INTENT(IN) :: paprs
    516     REAL, DIMENSION(klon, klev), INTENT(IN)   :: pplay
    517     REAL, DIMENSION(klon, klev), INTENT(IN)   :: t(klon,klev)
    518    
    519     REAL, DIMENSION(klon, klev), INTENT(OUT)  :: pcfm, pcfh
    520 
    521 ! Quelques constantes et options:
    522 
    523     REAL, PARAMETER :: prandtl=0.4
    524     REAL, PARAMETER :: kstable=0.002
    525 !   REAL, PARAMETER :: kstable=0.001
    526     REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange
    527     REAL, PARAMETER :: seuil=-0.02 ! au-dela l'inversion est consideree trop faible
    528 !    PARAMETER (seuil=-0.04)
    529 !    PARAMETER (seuil=-0.06)
    530 !    PARAMETER (seuil=-0.09)
    531 
    532 ! Variables locales:
     493    !======================================================================
     494    ! J'introduit un peu de diffusion sauf dans les endroits
     495    ! ou une forte inversion est presente
     496    ! On peut dire qu'il represente la convection peu profonde
     497
     498    ! Arguments:
     499    ! nsrf-----input-I- indicateur de la nature du sol
     500    ! knon-----input-I- nombre de points a traiter
     501    ! paprs----input-R- pression a chaque intercouche (en Pa)
     502    ! pplay----input-R- pression au milieu de chaque couche (en Pa)
     503    ! t--------input-R- temperature (K)
     504
     505    ! pcfm-----output-R- coefficients a calculer (vitesse)
     506    ! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
     507    !======================================================================
     508
     509    ! Arguments:
     510
     511    INTEGER, INTENT(IN) :: knon, nsrf
     512    REAL, DIMENSION(klon, klev + 1), INTENT(IN) :: paprs
     513    REAL, DIMENSION(klon, klev), INTENT(IN) :: pplay
     514    REAL, DIMENSION(klon, klev), INTENT(IN) :: t(klon, klev)
     515
     516    REAL, DIMENSION(klon, klev), INTENT(OUT) :: pcfm, pcfh
     517
     518    ! Quelques constantes et options:
     519
     520    REAL, PARAMETER :: prandtl = 0.4
     521    REAL, PARAMETER :: kstable = 0.002
     522    !   REAL, PARAMETER :: kstable=0.001
     523    REAL, PARAMETER :: mixlen = 35.0 ! constante controlant longueur de melange
     524    REAL, PARAMETER :: seuil = -0.02 ! au-dela l'inversion est consideree trop faible
     525    !    PARAMETER (seuil=-0.04)
     526    !    PARAMETER (seuil=-0.06)
     527    !    PARAMETER (seuil=-0.09)
     528
     529    ! Variables locales:
    533530
    534531    INTEGER i, k, invb(knon)
    … …  
    538535    INCLUDE "YOMCST.h"
    539536
    540 ! Initialiser les sorties
     537    ! Initialiser les sorties
    541538
    542539    DO k = 1, klev
    543        DO i = 1, knon
    544           pcfm(i,k) = 0.0
    545           pcfh(i,k) = 0.0
    546        ENDDO
    547     ENDDO
    548 
    549 ! Chercher la zone d'inversion forte
     540      DO i = 1, knon
     541        pcfm(i, k) = 0.0
     542        pcfh(i, k) = 0.0
     543      ENDDO
     544    ENDDO
     545
     546    ! Chercher la zone d'inversion forte
    550547
    551548    DO i = 1, knon
    552        invb(i) = klev
    553        zdthmin(i)=0.0
    554     ENDDO
    555     DO k = 2, klev/2-1
    556        DO i = 1, knon
    557           zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
    558                - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
    559           zdthdp = zdthdp * 100.0
    560           IF (pplay(i,k)>0.8*paprs(i,1) .AND. &
    561                zdthdp<zdthmin(i) ) THEN
    562              zdthmin(i) = zdthdp
    563              invb(i) = k
     549      invb(i) = klev
     550      zdthmin(i) = 0.0
     551    ENDDO
     552    DO k = 2, klev / 2 - 1
     553      DO i = 1, knon
     554        zdthdp = (t(i, k) - t(i, k + 1)) / (pplay(i, k) - pplay(i, k + 1)) &
     555                - RD * 0.5 * (t(i, k) + t(i, k + 1)) / RCPD / paprs(i, k + 1)
     556        zdthdp = zdthdp * 100.0
     557        IF (pplay(i, k)>0.8 * paprs(i, 1) .AND. &
     558                zdthdp<zdthmin(i)) THEN
     559          zdthmin(i) = zdthdp
     560          invb(i) = k
     561        ENDIF
     562      ENDDO
     563    ENDDO
     564
     565    ! Introduire une diffusion:
     566
     567    IF (nsrf==is_oce) THEN
     568      DO k = 2, klev
     569        DO i = 1, knon
     570          !IM cf FH/GK   IF ( (nsrf.NE.is_oce) .OR.  ! si ce n'est pas sur l'ocean
     571          !IM cf FH/GK  .     (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion
     572          !IM cf JLD/ GKtest TERkz2
     573          ! IF ( (nsrf.EQ.is_ter) .OR.  ! si on est sur la terre
     574          ! fin GKtest
     575
     576
     577          ! s'il n'y a pas d'inversion ou si l'inversion est trop faible
     578          !          IF ( (nsrf.EQ.is_oce) .AND. &
     579          IF ((invb(i)==klev) .OR. (zdthmin(i)>seuil)) THEN
     580            zl2(i) = (mixlen * MAX(0.0, (paprs(i, k) - paprs(i, klev + 1)) &
     581                    / (paprs(i, 2) - paprs(i, klev + 1))))**2
     582            pcfm(i, k) = zl2(i) * kstable
     583            pcfh(i, k) = pcfm(i, k) / prandtl ! h et m different
    564584          ENDIF
    565        ENDDO
    566     ENDDO
    567 
    568 ! Introduire une diffusion:
    569 
    570     IF ( nsrf==is_oce ) THEN
    571        DO k = 2, klev
    572           DO i = 1, knon
    573 !IM cf FH/GK   IF ( (nsrf.NE.is_oce) .OR.  ! si ce n'est pas sur l'ocean
    574 !IM cf FH/GK  .     (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion
    575       !IM cf JLD/ GKtest TERkz2
    576       ! IF ( (nsrf.EQ.is_ter) .OR.  ! si on est sur la terre
    577       ! fin GKtest
    578 
    579 
    580 ! s'il n'y a pas d'inversion ou si l'inversion est trop faible
    581 !          IF ( (nsrf.EQ.is_oce) .AND. &
    582              IF ( (invb(i)==klev) .OR. (zdthmin(i)>seuil) ) THEN
    583                 zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1)) &
    584                      /(paprs(i,2)-paprs(i,klev+1)) ))**2
    585                 pcfm(i,k)= zl2(i)* kstable
    586                 pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
    587              ENDIF
    588           ENDDO
    589        ENDDO
     585        ENDDO
     586      ENDDO
    590587    ENDIF
    591588
    592589  END SUBROUTINE coefkz2
    593590
    594 !****************************************************************************************
     591  !****************************************************************************************
    595592
    596593END MODULE coef_diff_turb_mod

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

    r5137 r5143  
    1010      USE lmdz_abort_physic, ONLY: abort_physic
    1111      USE lmdz_clesphys
     12      USE lmdz_YOETHF
    1213
    1314      IMPLICIT NONE
    … …  
    5354
    5455      include "YOMCST.h"
    55       include "YOETHF.h"
    5656! Quelques constantes :
    5757      REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0, cepdu2=(0.1)**2

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

    r5113 r5143  
    1 
    21! $Header$
    32
    43SUBROUTINE conccm(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, rain, snow, &
    5     kbascm, ktopcm)
     4        kbascm, ktopcm)
    65
    76  USE dimphy
     7  USE lmdz_YOETHF
     8
    89  IMPLICIT NONE
    910  ! ======================================================================
    … …  
    1314  ! ======================================================================
    1415  include "YOMCST.h"
    15   include "YOETHF.h"
    1616
    1717  ! Entree:
    1818  REAL dtime ! pas d'integration
    19   REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
     19  REAL paprs(klon, klev + 1) ! pression inter-couche (Pa)
    2020  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
    2121  REAL t(klon, klev) ! temperature (K)
    … …  
    4343
    4444  LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
    45   PARAMETER (usekuo=.TRUE.)
     45  PARAMETER (usekuo = .TRUE.)
    4646
    4747  REAL d_t_bis(klon, klev)
    … …  
    7272  DO k = 1, klev
    7373    DO i = 1, klon
    74       pt(i, k) = t(i, klev-k+1)
    75       pq(i, k) = q(i, klev-k+1)
    76       pres(i, k) = pplay(i, klev-k+1)
    77       dp(i, k) = paprs(i, klev+1-k) - paprs(i, klev+1-k+1)
     74      pt(i, k) = t(i, klev - k + 1)
     75      pq(i, k) = q(i, klev - k + 1)
     76      pres(i, k) = pplay(i, klev - k + 1)
     77      dp(i, k) = paprs(i, klev + 1 - k) - paprs(i, klev + 1 - k + 1)
    7878    END DO
    7979  END DO
    8080  DO i = 1, klon
    81     zgeom(i, klev) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i, &
    82       1)))*(paprs(i,1)-pplay(i,1))
     81    zgeom(i, klev) = rd * t(i, 1) / (0.5 * (paprs(i, 1) + pplay(i, &
     82            1))) * (paprs(i, 1) - pplay(i, 1))
    8383  END DO
    8484  DO k = 2, klev
    8585    DO i = 1, klon
    86       zgeom(i, klev+1-k) = zgeom(i, klev+1-k+1) + rd*0.5*(t(i,k-1)+t(i,k))/ &
    87         paprs(i, k)*(pplay(i,k-1)-pplay(i,k))
     86      zgeom(i, klev + 1 - k) = zgeom(i, klev + 1 - k + 1) + rd * 0.5 * (t(i, k - 1) + t(i, k)) / &
     87              paprs(i, k) * (pplay(i, k - 1) - pplay(i, k))
    8888    END DO
    8989  END DO
    … …  
    9393  DO k = 1, klev
    9494    DO i = 1, klon
    95       d_q(i, klev+1-k) = pq(i, k) - q(i, klev+1-k)
    96       d_t(i, klev+1-k) = pt(i, k) - t(i, klev+1-k)
     95      d_q(i, klev + 1 - k) = pq(i, k) - q(i, klev + 1 - k)
     96      d_t(i, klev + 1 - k) = pt(i, k) - t(i, klev + 1 - k)
    9797    END DO
    9898  END DO
    9999
    100100  DO i = 1, klon
    101     rain(i) = cmfprt(i)*rhoh2o
    102     snow(i) = cmfprs(i)*rhoh2o
     101    rain(i) = cmfprt(i) * rhoh2o
     102    snow(i) = cmfprs(i) * rhoh2o
    103103    kbascm(i) = klev + 1 - nbas(i)
    104104    ktopcm(i) = klev + 1 - ntop(i)
    … …  
    107107  IF (usekuo) THEN
    108108    CALL conkuo(dtime, paprs, pplay, t, q, conv_q, d_t_bis, d_q_bis, &
    109       d_ql_bis, rneb_bis, rain_bis, snow_bis, ibas_bis, itop_bis)
     109            d_ql_bis, rneb_bis, rain_bis, snow_bis, ibas_bis, itop_bis)
    110110    DO k = 1, klev
    111111      DO i = 1, klon
    … …  
    122122    DO k = 1, klev ! eau liquide convective est
    123123      DO i = 1, klon ! dispersee dans l'air
    124         zlvdcp = rlvtt/rcpd/(1.0+rvtmp2*q(i,k))
    125         zlsdcp = rlstt/rcpd/(1.0+rvtmp2*q(i,k))
    126         zdelta = max(0., sign(1.,rtt-t(i,k)))
     124        zlvdcp = rlvtt / rcpd / (1.0 + rvtmp2 * q(i, k))
     125        zlsdcp = rlstt / rcpd / (1.0 + rvtmp2 * q(i, k))
     126        zdelta = max(0., sign(1., rtt - t(i, k)))
    127127        zz = d_ql_bis(i, k) ! re-evap. de l'eau liquide
    128128        zb = max(0.0, zz)
    129         za = -max(0.0, zz)*(zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
     129        za = -max(0.0, zz) * (zlvdcp * (1. - zdelta) + zlsdcp * zdelta)
    130130        d_t(i, k) = d_t(i, k) + za
    131131        d_q(i, k) = d_q(i, k) + zb
    … …  
    134134  END IF
    135135
    136 
    137136END SUBROUTINE conccm
    138137SUBROUTINE cmfmca(deltat, p, dp, gz, tb, shb, cmfprt, cmfprs, cnt, cnb)
    139138  USE dimphy
     139  USE lmdz_YOETHF
     140  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     141
    140142  IMPLICIT NONE
    141143  ! -----------------------------------------------------------------------
    … …  
    159161  ! -----------------------------------------------------------------------
    160162  INTEGER pcnst ! nombre de traceurs passifs
    161   PARAMETER (pcnst=1)
     163  PARAMETER (pcnst = 1)
    162164  ! ------------------------------Arguments--------------------------------
    163165  ! Input arguments
    … …  
    194196  ! ------------------------------Parameters-------------------------------
    195197  REAL c0 ! rain water autoconversion coefficient
    196   PARAMETER (c0=1.0E-4)
     198  PARAMETER (c0 = 1.0E-4)
    197199  REAL dzmin ! minimum convective depth for precipitation
    198   PARAMETER (dzmin=0.0)
     200  PARAMETER (dzmin = 0.0)
    199201  REAL betamn ! minimum overshoot parameter
    200   PARAMETER (betamn=0.10)
     202  PARAMETER (betamn = 0.10)
    201203  REAL cmftau ! characteristic adjustment time scale
    202   PARAMETER (cmftau=3600.)
     204  PARAMETER (cmftau = 3600.)
    203205  INTEGER limcnv ! top interface level limit for convection
    204   PARAMETER (limcnv=1)
     206  PARAMETER (limcnv = 1)
    205207  REAL tpmax ! maximum acceptable t perturbation (degrees C)
    206   PARAMETER (tpmax=1.50)
     208  PARAMETER (tpmax = 1.50)
    207209  REAL shpmax ! maximum acceptable q perturbation (g/g)
    208   PARAMETER (shpmax=1.50E-3)
     210  PARAMETER (shpmax = 1.50E-3)
    209211  REAL tiny ! arbitrary small num used in transport estimates
    210   PARAMETER (tiny=1.0E-36)
     212  PARAMETER (tiny = 1.0E-36)
    211213  REAL eps ! convergence criteria (machine dependent)
    212   PARAMETER (eps=1.0E-13)
     214  PARAMETER (eps = 1.0E-13)
    213215  REAL tmelt ! freezing point of water(req'd for rain vs snow)
    214   PARAMETER (tmelt=273.15)
     216  PARAMETER (tmelt = 273.15)
    215217  REAL ssfac ! supersaturation bound (detrained air)
    216   PARAMETER (ssfac=1.001)
     218  PARAMETER (ssfac = 1.001)
    217219
    218220  ! ---------------------------Local workspace-----------------------------
    … …  
    222224  REAL shbs(klon, klev) ! sat. specific humidity (sh bar star)
    223225  REAL hbs(klon, klev) ! sat. moist static energy (h bar star)
    224   REAL shbh(klon, klev+1) ! specific humidity on interfaces
    225   REAL sbh(klon, klev+1) ! s bar on interfaces
    226   REAL hbh(klon, klev+1) ! h bar on interfaces
    227   REAL cmrh(klon, klev+1) ! interface constituent mixing ratio
     226  REAL shbh(klon, klev + 1) ! specific humidity on interfaces
     227  REAL sbh(klon, klev + 1) ! s bar on interfaces
     228  REAL hbh(klon, klev + 1) ! h bar on interfaces
     229  REAL cmrh(klon, klev + 1) ! interface constituent mixing ratio
    228230  REAL prec(klon) ! instantaneous total precipitation
    229231  REAL dzcld(klon) ! depth of convective layer (m)
    … …  
    291293  REAL qhalf, sh1, sh2, shbs1, shbs2
    292294  include "YOMCST.h"
    293   include "YOETHF.h"
    294   include "FCTTRE.h"
    295   qhalf(sh1, sh2, shbs1, shbs2) = min(max(sh1,sh2), &
    296     (shbs2*sh1+shbs1*sh2)/(shbs1+shbs2))
     295  qhalf(sh1, sh2, shbs1, shbs2) = min(max(sh1, sh2), &
     296          (shbs2 * sh1 + shbs1 * sh2) / (shbs1 + shbs2))
    297297
    298298  ! -----------------------------------------------------------------------
    … …  
    324324  dt = deltat
    325325  cats = max(dt, cmftau)
    326   rdt = 1.0/dt
     326  rdt = 1.0 / dt
    327327
    328328  ! Compute sb,hb,shbs,hbs
    … …  
    333333      zx_p = p(i, k)
    334334      zx_q = shb(i, k)
    335       zdelta = max(0., sign(1.,rtt-zx_t))
    336       zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
    337       zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zx_q)
    338       zx_qs = r2es*foeew(zx_t, zdelta)/zx_p
     335      zdelta = max(0., sign(1., rtt - zx_t))
     336      zcvm5 = r5les * rlvtt * (1. - zdelta) + r5ies * rlstt * zdelta
     337      zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * zx_q)
     338      zx_qs = r2es * foeew(zx_t, zdelta) / zx_p
    339339      zx_qs = min(0.5, zx_qs)
    340       zcor = 1./(1.-retv*zx_qs)
    341       zx_qs = zx_qs*zcor
     340      zcor = 1. / (1. - retv * zx_qs)
     341      zx_qs = zx_qs * zcor
    342342      zx_gam = foede(zx_t, zdelta, zcvm5, zx_qs, zcor)
    343343      shbs(i, k) = zx_qs
    … …  
    348348  DO k = limcnv, klev
    349349    DO i = 1, klon
    350       sb(i, k) = rcpd*tb(i, k) + gz(i, k)
    351       hb(i, k) = sb(i, k) + rlvtt*shb(i, k)
    352       hbs(i, k) = sb(i, k) + rlvtt*shbs(i, k)
     350      sb(i, k) = rcpd * tb(i, k) + gz(i, k)
     351      hb(i, k) = sb(i, k) + rlvtt * shb(i, k)
     352      hbs(i, k) = sb(i, k) + rlvtt * shbs(i, k)
    353353    END DO
    354354  END DO
    … …  
    359359    km1 = k - 1
    360360    DO i = 1, klon
    361       sbh(i, k) = 0.5*(sb(i,km1)+sb(i,k))
    362       shbh(i, k) = qhalf(shb(i,km1), shb(i,k), shbs(i,km1), shbs(i,k))
    363       hbh(i, k) = sbh(i, k) + rlvtt*shbh(i, k)
     361      sbh(i, k) = 0.5 * (sb(i, km1) + sb(i, k))
     362      shbh(i, k) = qhalf(shb(i, km1), shb(i, k), shbs(i, km1), shbs(i, k))
     363      hbh(i, k) = sbh(i, k) + rlvtt * shbh(i, k)
    364364    END DO
    365365  END DO
    … …  
    425425
    426426      pblhgt = max(pblh(i), 1.0)
    427       IF (gz(i,kp1)/rg<=pblhgt .AND. dzcld(i)==0.0) THEN
    428         fac1 = max(0.0, 1.0-gz(i,kp1)/rg/pblhgt)
    429         tprime = min(thtap(i), tpmax)*fac1
    430         qsattp = shbs(i, kp1) + rcpd/rlvtt*gam(i, kp1)*tprime
    431         shprme = min(min(shp(i),shpmax)*fac1, max(qsattp-shb(i,kp1),0.0))
     427      IF (gz(i, kp1) / rg<=pblhgt .AND. dzcld(i)==0.0) THEN
     428        fac1 = max(0.0, 1.0 - gz(i, kp1) / rg / pblhgt)
     429        tprime = min(thtap(i), tpmax) * fac1
     430        qsattp = shbs(i, kp1) + rcpd / rlvtt * gam(i, kp1) * tprime
     431        shprme = min(min(shp(i), shpmax) * fac1, max(qsattp - shb(i, kp1), 0.0))
    432432        qprime = max(qprime, shprme)
    433433      ELSE
    … …  
    438438      ! Specify "updraft" (in-cloud) thermodynamic properties
    439439
    440       sc(i) = sb(i, kp1) + rcpd*tprime
     440      sc(i) = sb(i, kp1) + rcpd * tprime
    441441      shc(i) = shb(i, kp1) + qprime
    442       hc(i) = sc(i) + rlvtt*shc(i)
     442      hc(i) = sc(i) + rlvtt * shc(i)
    443443      flotab(i) = hc(i) - hbs(i, k)
    444       dz = dp(i, k)*rd*tb(i, k)/rg/p(i, k)
     444      dz = dp(i, k) * rd * tb(i, k) / rg / p(i, k)
    445445      IF (flotab(i)>0.0) THEN
    446446        dzcld(i) = dzcld(i) + dz
    … …  
    471471    ! Current level just below top level => no overshoot
    472472
    473     IF (k<=limcnv+1) THEN
     473    IF (k<=limcnv + 1) THEN
    474474      DO i = 1, klon
    475475        IF (ldcum(i)) THEN
    476           cldwtr(i) = sb(i, k) - sc(i) + flotab(i)/(1.0+gam(i,k))
     476          cldwtr(i) = sb(i, k) - sc(i) + flotab(i) / (1.0 + gam(i, k))
    477477          cldwtr(i) = max(0.0, cldwtr(i))
    478478          beta(i) = 0.0
    … …  
    489489    DO i = 1, klon
    490490      IF (ldcum(i)) THEN
    491         cldwtr(i) = sb(i, k) - sc(i) + flotab(i)/(1.0+gam(i,k))
     491        cldwtr(i) = sb(i, k) - sc(i) + flotab(i) / (1.0 + gam(i, k))
    492492        cldwtr(i) = max(0.0, cldwtr(i))
    493         betamx = 1.0 - c0*max(0.0, (dzcld(i)-dzmin))
    494         b1 = (hc(i)-hbs(i,km1))*dp(i, km1)
    495         b2 = (hc(i)-hbs(i,k))*dp(i, k)
    496         beta(i) = max(betamn, min(betamx,1.0+b1/b2))
    497         IF (hbs(i,km1)<=hb(i,km1)) beta(i) = 0.0
     493        betamx = 1.0 - c0 * max(0.0, (dzcld(i) - dzmin))
     494        b1 = (hc(i) - hbs(i, km1)) * dp(i, km1)
     495        b2 = (hc(i) - hbs(i, k)) * dp(i, k)
     496        beta(i) = max(betamn, min(betamx, 1.0 + b1 / b2))
     497        IF (hbs(i, km1)<=hb(i, km1)) beta(i) = 0.0
    498498      END IF
    499499    END DO
    … …  
    507507    DO i = 1, klon
    508508      IF (ldcum(i)) THEN
    509         tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) - &
    510           (hbh(i,kp1)-hc(i))*dp(i, k)/dp(i, kp1)
    511         tmp2 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))
    512         IF ((beta(i)*tmp2-tmp1)>0.0) THEN
    513           betamx = 0.99*(tmp1/tmp2)
    514           beta(i) = max(0.0, min(betamx,beta(i)))
     509        tmp1 = (1.0 + gam(i, k)) * (sc(i) - sbh(i, kp1) + cldwtr(i)) - &
     510                (hbh(i, kp1) - hc(i)) * dp(i, k) / dp(i, kp1)
     511        tmp2 = (1.0 + gam(i, k)) * (sc(i) - sbh(i, k))
     512        IF ((beta(i) * tmp2 - tmp1)>0.0) THEN
     513          betamx = 0.99 * (tmp1 / tmp2)
     514          beta(i) = max(0.0, min(betamx, beta(i)))
    515515        END IF
    516516
    … …  
    521521        ! est acceptee (facteur ssfac).
    522522
    523         IF (hb(i,km1)<hbs(i,km1)) THEN
    524           tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) - &
    525             (hbh(i,kp1)-hc(i))*dp(i, k)/dp(i, kp1)
    526           tmp1 = tmp1/dp(i, k)
    527           tmp2 = gam(i, km1)*(sbh(i,k)-sc(i)+cldwtr(i)) - hbh(i, k) + hc(i) - &
    528             sc(i) + sbh(i, k)
    529           tmp3 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i, k)
    530           tmp4 = (dt/cats)*(hc(i)-hbs(i,k))*tmp2/(dp(i,km1)*(hbs(i,km1)-hb(i, &
    531             km1))) + tmp3
    532           IF ((beta(i)*tmp4-tmp1)>0.0) THEN
    533             betamx = ssfac*(tmp1/tmp4)
    534             beta(i) = max(0.0, min(betamx,beta(i)))
     523        IF (hb(i, km1)<hbs(i, km1)) THEN
     524          tmp1 = (1.0 + gam(i, k)) * (sc(i) - sbh(i, kp1) + cldwtr(i)) - &
     525                  (hbh(i, kp1) - hc(i)) * dp(i, k) / dp(i, kp1)
     526          tmp1 = tmp1 / dp(i, k)
     527          tmp2 = gam(i, km1) * (sbh(i, k) - sc(i) + cldwtr(i)) - hbh(i, k) + hc(i) - &
     528                  sc(i) + sbh(i, k)
     529          tmp3 = (1.0 + gam(i, k)) * (sc(i) - sbh(i, k)) / dp(i, k)
     530          tmp4 = (dt / cats) * (hc(i) - hbs(i, k)) * tmp2 / (dp(i, km1) * (hbs(i, km1) - hb(i, &
     531                  km1))) + tmp3
     532          IF ((beta(i) * tmp4 - tmp1)>0.0) THEN
     533            betamx = ssfac * (tmp1 / tmp4)
     534            beta(i) = max(0.0, min(betamx, beta(i)))
    535535          END IF
    536536        ELSE
    … …  
    542542        ! so that the adjustment doesn't contribute to "kinks" in h
    543543
    544         g = min(0.0, hb(i,k)-hb(i,km1))
    545         tmp3 = (hb(i,k)-hb(i,km1)-g)*(cats/dt)/(hc(i)-hbs(i,k))
    546         tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) - &
    547           (hbh(i,kp1)-hc(i))*dp(i, k)/dp(i, kp1)
    548         tmp1 = tmp1/dp(i, k)
    549         tmp1 = tmp3*tmp1 + (hc(i)-hbh(i,kp1))/dp(i, k)
    550         tmp2 = tmp3*(1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i, k) + &
    551           (hc(i)-hbh(i,k)-cldwtr(i))*(1.0/dp(i,k)+1.0/dp(i,kp1))
    552         IF ((beta(i)*tmp2-tmp1)>0.0) THEN
     544        g = min(0.0, hb(i, k) - hb(i, km1))
     545        tmp3 = (hb(i, k) - hb(i, km1) - g) * (cats / dt) / (hc(i) - hbs(i, k))
     546        tmp1 = (1.0 + gam(i, k)) * (sc(i) - sbh(i, kp1) + cldwtr(i)) - &
     547                (hbh(i, kp1) - hc(i)) * dp(i, k) / dp(i, kp1)
     548        tmp1 = tmp1 / dp(i, k)
     549        tmp1 = tmp3 * tmp1 + (hc(i) - hbh(i, kp1)) / dp(i, k)
     550        tmp2 = tmp3 * (1.0 + gam(i, k)) * (sc(i) - sbh(i, k)) / dp(i, k) + &
     551                (hc(i) - hbh(i, k) - cldwtr(i)) * (1.0 / dp(i, k) + 1.0 / dp(i, kp1))
     552        IF ((beta(i) * tmp2 - tmp1)>0.0) THEN
    553553          betamx = 0.0
    554           IF (tmp2/=0.0) betamx = tmp1/tmp2
    555           beta(i) = max(0.0, min(betamx,beta(i)))
     554          IF (tmp2/=0.0) betamx = tmp1 / tmp2
     555          beta(i) = max(0.0, min(betamx, beta(i)))
    556556        END IF
    557557      END IF
    … …  
    567567    ! physical states and adjust eta accordingly.
    568568
    569 20  CONTINUE
     569    20  CONTINUE
    570570    DO i = 1, klon
    571571      IF (ldcum(i)) THEN
    572572        beta(i) = max(0.0, beta(i))
    573573        tmp1 = hc(i) - hbs(i, k)
    574         tmp2 = ((1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i))-beta(i)*(1.0+gam( &
    575           i,k))*(sc(i)-sbh(i,k)))/dp(i, k) - (hbh(i,kp1)-hc(i))/dp(i, kp1)
    576         eta(i) = tmp1/(tmp2*rg*cats)
    577         tmass = min(dp(i,k), dp(i,kp1))/rg
    578         IF (eta(i)>tmass*rdt .OR. eta(i)<=0.0) eta(i) = 0.0
     574        tmp2 = ((1.0 + gam(i, k)) * (sc(i) - sbh(i, kp1) + cldwtr(i)) - beta(i) * (1.0 + gam(&
     575                i, k)) * (sc(i) - sbh(i, k))) / dp(i, k) - (hbh(i, kp1) - hc(i)) / dp(i, kp1)
     576        eta(i) = tmp1 / (tmp2 * rg * cats)
     577        tmass = min(dp(i, k), dp(i, kp1)) / rg
     578        IF (eta(i)>tmass * rdt .OR. eta(i)<=0.0) eta(i) = 0.0
    579579
    580580        ! Check on negative q in top layer (bound beta)
    581581
    582         IF (shc(i)-shbh(i,k)<0.0 .AND. beta(i)*eta(i)/=0.0) THEN
    583           denom = eta(i)*rg*dt*(shc(i)-shbh(i,k))/dp(i, km1)
    584           beta(i) = max(0.0, min(-0.999*shb(i,km1)/denom,beta(i)))
     582        IF (shc(i) - shbh(i, k)<0.0 .AND. beta(i) * eta(i)/=0.0) THEN
     583          denom = eta(i) * rg * dt * (shc(i) - shbh(i, k)) / dp(i, km1)
     584          beta(i) = max(0.0, min(-0.999 * shb(i, km1) / denom, beta(i)))
    585585        END IF
    586586
    587587        ! Check on negative q in middle layer (zero eta)
    588588
    589         qtest1 = shb(i, k) + eta(i)*rg*dt*((shc(i)-shbh(i, &
    590           kp1))-(1.0-beta(i))*cldwtr(i)/rlvtt-beta(i)*(shc(i)-shbh(i, &
    591           k)))/dp(i, k)
     589        qtest1 = shb(i, k) + eta(i) * rg * dt * ((shc(i) - shbh(i, &
     590                kp1)) - (1.0 - beta(i)) * cldwtr(i) / rlvtt - beta(i) * (shc(i) - shbh(i, &
     591                k))) / dp(i, k)
    592592        IF (qtest1<=0.0) eta(i) = 0.0
    593593
    594594        ! Check on negative q in lower layer (bound eta)
    595595
    596         fac1 = -(shbh(i,kp1)-shc(i))/dp(i, kp1)
    597         qtest2 = shb(i, kp1) - eta(i)*rg*dt*fac1
     596        fac1 = -(shbh(i, kp1) - shc(i)) / dp(i, kp1)
     597        qtest2 = shb(i, kp1) - eta(i) * rg * dt * fac1
    598598        IF (qtest2<0.0) THEN
    599           eta(i) = 0.99*shb(i, kp1)/(rg*dt*fac1)
     599          eta(i) = 0.99 * shb(i, kp1) / (rg * dt * fac1)
    600600        END IF
    601601      END IF
    … …  
    607607    DO i = 1, klon
    608608      IF (ldcum(i)) THEN
    609         etagdt = eta(i)*rg*dt
    610         cldwtr(i) = etagdt*cldwtr(i)/rlvtt/rg
    611         rnwtr(i) = (1.0-beta(i))*cldwtr(i)
    612         ds1(i) = etagdt*(sbh(i,kp1)-sc(i))/dp(i, kp1)
    613         dq1(i) = etagdt*(shbh(i,kp1)-shc(i))/dp(i, kp1)
    614         ds2(i) = (etagdt*(sc(i)-sbh(i,kp1))+rlvtt*rg*cldwtr(i)-beta(i)*etagdt &
    615           *(sc(i)-sbh(i,k)))/dp(i, k)
    616         dq2(i) = (etagdt*(shc(i)-shbh(i,kp1))-rg*rnwtr(i)-beta(i)*etagdt*(shc &
    617           (i)-shbh(i,k)))/dp(i, k)
    618         ds3(i) = beta(i)*(etagdt*(sc(i)-sbh(i,k))-rlvtt*rg*cldwtr(i))/dp(i, &
    619           km1)
    620         dq3(i) = beta(i)*etagdt*(shc(i)-shbh(i,k))/dp(i, km1)
     609        etagdt = eta(i) * rg * dt
     610        cldwtr(i) = etagdt * cldwtr(i) / rlvtt / rg
     611        rnwtr(i) = (1.0 - beta(i)) * cldwtr(i)
     612        ds1(i) = etagdt * (sbh(i, kp1) - sc(i)) / dp(i, kp1)
     613        dq1(i) = etagdt * (shbh(i, kp1) - shc(i)) / dp(i, kp1)
     614        ds2(i) = (etagdt * (sc(i) - sbh(i, kp1)) + rlvtt * rg * cldwtr(i) - beta(i) * etagdt &
     615                * (sc(i) - sbh(i, k))) / dp(i, k)
     616        dq2(i) = (etagdt * (shc(i) - shbh(i, kp1)) - rg * rnwtr(i) - beta(i) * etagdt * (shc &
     617                (i) - shbh(i, k))) / dp(i, k)
     618        ds3(i) = beta(i) * (etagdt * (sc(i) - sbh(i, k)) - rlvtt * rg * cldwtr(i)) / dp(i, &
     619                km1)
     620        dq3(i) = beta(i) * etagdt * (shc(i) - shbh(i, k)) / dp(i, km1)
    621621
    622622        ! Isolate convective fluxes for later diagnostics
    623623
    624         fslkp = eta(i)*(sc(i)-sbh(i,kp1))
    625         fslkm = beta(i)*(eta(i)*(sc(i)-sbh(i,k))-rlvtt*cldwtr(i)*rdt)
    626         fqlkp = eta(i)*(shc(i)-shbh(i,kp1))
    627         fqlkm = beta(i)*eta(i)*(shc(i)-shbh(i,k))
     624        fslkp = eta(i) * (sc(i) - sbh(i, kp1))
     625        fslkm = beta(i) * (eta(i) * (sc(i) - sbh(i, k)) - rlvtt * cldwtr(i) * rdt)
     626        fqlkp = eta(i) * (shc(i) - shbh(i, kp1))
     627        fqlkm = beta(i) * eta(i) * (shc(i) - shbh(i, k))
    628628
    629629
    630630        ! Update thermodynamic profile (update sb, hb, & hbs later)
    631631
    632         tb(i, kp1) = tb(i, kp1) + ds1(i)/rcpd
    633         tb(i, k) = tb(i, k) + ds2(i)/rcpd
    634         tb(i, km1) = tb(i, km1) + ds3(i)/rcpd
     632        tb(i, kp1) = tb(i, kp1) + ds1(i) / rcpd
     633        tb(i, k) = tb(i, k) + ds2(i) / rcpd
     634        tb(i, km1) = tb(i, km1) + ds3(i) / rcpd
    635635        shb(i, kp1) = shb(i, kp1) + dq1(i)
    636636        shb(i, k) = shb(i, k) + dq2(i)
    637637        shb(i, km1) = shb(i, km1) + dq3(i)
    638         prec(i) = prec(i) + rnwtr(i)/rhoh2o
     638        prec(i) = prec(i) + rnwtr(i) / rhoh2o
    639639
    640640        ! Update diagnostic information for final budget
    … …  
    643643        ! water static energy flux, and convective total water flux
    644644
    645         cmfdt(i, kp1) = cmfdt(i, kp1) + ds1(i)/rcpd*rdt
    646         cmfdt(i, k) = cmfdt(i, k) + ds2(i)/rcpd*rdt
    647         cmfdt(i, km1) = cmfdt(i, km1) + ds3(i)/rcpd*rdt
    648         cmfdq(i, kp1) = cmfdq(i, kp1) + dq1(i)*rdt
    649         cmfdq(i, k) = cmfdq(i, k) + dq2(i)*rdt
    650         cmfdq(i, km1) = cmfdq(i, km1) + dq3(i)*rdt
    651         cmfdqr(i, k) = cmfdqr(i, k) + (rg*rnwtr(i)/dp(i,k))*rdt
     645        cmfdt(i, kp1) = cmfdt(i, kp1) + ds1(i) / rcpd * rdt
     646        cmfdt(i, k) = cmfdt(i, k) + ds2(i) / rcpd * rdt
     647        cmfdt(i, km1) = cmfdt(i, km1) + ds3(i) / rcpd * rdt
     648        cmfdq(i, kp1) = cmfdq(i, kp1) + dq1(i) * rdt
     649        cmfdq(i, k) = cmfdq(i, k) + dq2(i) * rdt
     650        cmfdq(i, km1) = cmfdq(i, km1) + dq3(i) * rdt
     651        cmfdqr(i, k) = cmfdqr(i, k) + (rg * rnwtr(i) / dp(i, k)) * rdt
    652652        cmfmc(i, kp1) = cmfmc(i, kp1) + eta(i)
    653         cmfmc(i, k) = cmfmc(i, k) + beta(i)*eta(i)
     653        cmfmc(i, k) = cmfmc(i, k) + beta(i) * eta(i)
    654654        cmfsl(i, kp1) = cmfsl(i, kp1) + fslkp
    655655        cmfsl(i, k) = cmfsl(i, k) + fslkm
    656         cmflq(i, kp1) = cmflq(i, kp1) + rlvtt*fqlkp
    657         cmflq(i, k) = cmflq(i, k) + rlvtt*fqlkm
    658         qc(i, k) = (rg*rnwtr(i)/dp(i,k))*rdt
     656        cmflq(i, kp1) = cmflq(i, kp1) + rlvtt * fqlkp
     657        cmflq(i, k) = cmflq(i, k) + rlvtt * fqlkm
     658        qc(i, k) = (rg * rnwtr(i) / dp(i, k)) * rdt
    659659      END IF
    660660    END DO
    … …  
    669669          ! the three adjacent levels, nothing will be done to the profile
    670670
    671           IF ((cmrb(i,kp1,m)<0.0) .OR. (cmrb(i,k,m)<0.0) .OR. (cmrb(i,km1, &
    672             m)<0.0)) GO TO 40
     671          IF ((cmrb(i, kp1, m)<0.0) .OR. (cmrb(i, k, m)<0.0) .OR. (cmrb(i, km1, &
     672                  m)<0.0)) GO TO 40
    673673
    674674          ! Specify constituent interface values (linear interpolation)
    675675
    676           cmrh(i, k) = 0.5*(cmrb(i,km1,m)+cmrb(i,k,m))
    677           cmrh(i, kp1) = 0.5*(cmrb(i,k,m)+cmrb(i,kp1,m))
     676          cmrh(i, k) = 0.5 * (cmrb(i, km1, m) + cmrb(i, k, m))
     677          cmrh(i, kp1) = 0.5 * (cmrb(i, k, m) + cmrb(i, kp1, m))
    678678
    679679          ! Specify perturbation properties of constituents in PBL
    680680
    681681          pblhgt = max(pblh(i), 1.0)
    682           IF (gz(i,kp1)/rg<=pblhgt .AND. dzcld(i)==0.) THEN
    683             fac1 = max(0.0, 1.0-gz(i,kp1)/rg/pblhgt)
    684             cmrc(i) = cmrb(i, kp1, m) + cmrp(i, m)*fac1
     682          IF (gz(i, kp1) / rg<=pblhgt .AND. dzcld(i)==0.) THEN
     683            fac1 = max(0.0, 1.0 - gz(i, kp1) / rg / pblhgt)
     684            cmrc(i) = cmrb(i, kp1, m) + cmrp(i, m) * fac1
    685685          ELSE
    686686            cmrc(i) = cmrb(i, kp1, m)
    … …  
    692692          ! Tendency is modified (reduced) when pending disaster detected.
    693693
    694           etagdt = eta(i)*rg*dt
    695           botflx = etagdt*(cmrc(i)-cmrh(i,kp1))
    696           topflx = beta(i)*etagdt*(cmrc(i)-cmrh(i,k))
    697           dcmr1(i) = -botflx/dp(i, kp1)
     694          etagdt = eta(i) * rg * dt
     695          botflx = etagdt * (cmrc(i) - cmrh(i, kp1))
     696          topflx = beta(i) * etagdt * (cmrc(i) - cmrh(i, k))
     697          dcmr1(i) = -botflx / dp(i, kp1)
    698698          efac1 = 1.0
    699699          efac2 = 1.0
    700700          efac3 = 1.0
    701701
    702           IF (cmrb(i,kp1,m)+dcmr1(i)<0.0) THEN
    703             efac1 = max(tiny, abs(cmrb(i,kp1,m)/dcmr1(i))-eps)
     702          IF (cmrb(i, kp1, m) + dcmr1(i)<0.0) THEN
     703            efac1 = max(tiny, abs(cmrb(i, kp1, m) / dcmr1(i)) - eps)
    704704          END IF
    705705
    706706          IF (efac1==tiny .OR. efac1>1.0) efac1 = 0.0
    707           dcmr1(i) = -efac1*botflx/dp(i, kp1)
    708           dcmr2(i) = (efac1*botflx-topflx)/dp(i, k)
    709 
    710           IF (cmrb(i,k,m)+dcmr2(i)<0.0) THEN
    711             efac2 = max(tiny, abs(cmrb(i,k,m)/dcmr2(i))-eps)
     707          dcmr1(i) = -efac1 * botflx / dp(i, kp1)
     708          dcmr2(i) = (efac1 * botflx - topflx) / dp(i, k)
     709
     710          IF (cmrb(i, k, m) + dcmr2(i)<0.0) THEN
     711            efac2 = max(tiny, abs(cmrb(i, k, m) / dcmr2(i)) - eps)
    712712          END IF
    713713
    714714          IF (efac2==tiny .OR. efac2>1.0) efac2 = 0.0
    715           dcmr2(i) = (efac1*botflx-efac2*topflx)/dp(i, k)
    716           dcmr3(i) = efac2*topflx/dp(i, km1)
    717 
    718           IF (cmrb(i,km1,m)+dcmr3(i)<0.0) THEN
    719             efac3 = max(tiny, abs(cmrb(i,km1,m)/dcmr3(i))-eps)
     715          dcmr2(i) = (efac1 * botflx - efac2 * topflx) / dp(i, k)
     716          dcmr3(i) = efac2 * topflx / dp(i, km1)
     717
     718          IF (cmrb(i, km1, m) + dcmr3(i)<0.0) THEN
     719            efac3 = max(tiny, abs(cmrb(i, km1, m) / dcmr3(i)) - eps)
    720720          END IF
    721721
    722722          IF (efac3==tiny .OR. efac3>1.0) efac3 = 0.0
    723723          efac3 = min(efac2, efac3)
    724           dcmr2(i) = (efac1*botflx-efac3*topflx)/dp(i, k)
    725           dcmr3(i) = efac3*topflx/dp(i, km1)
     724          dcmr2(i) = (efac1 * botflx - efac3 * topflx) / dp(i, k)
     725          dcmr3(i) = efac3 * topflx / dp(i, km1)
    726726
    727727          cmrb(i, kp1, m) = cmrb(i, kp1, m) + dcmr1(i)
    … …  
    729729          cmrb(i, km1, m) = cmrb(i, km1, m) + dcmr3(i)
    730730        END IF
    731 40    END DO
     731      40    END DO
    732732    END DO ! end of m=1,pcnst loop
    733733
    734     IF (k==limcnv+1) GO TO 60 ! on ne pourra plus glisser
     734    IF (k==limcnv + 1) GO TO 60 ! on ne pourra plus glisser
    735735
    736736    ! Dans la procedure de glissage ascendant, les variables thermo-
    … …  
    743743        zx_p = p(i, k)
    744744        zx_q = shb(i, k)
    745         zdelta = max(0., sign(1.,rtt-zx_t))
    746         zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
    747         zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zx_q)
    748         zx_qs = r2es*foeew(zx_t, zdelta)/zx_p
     745        zdelta = max(0., sign(1., rtt - zx_t))
     746        zcvm5 = r5les * rlvtt * (1. - zdelta) + r5ies * rlstt * zdelta
     747        zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * zx_q)
     748        zx_qs = r2es * foeew(zx_t, zdelta) / zx_p
    749749        zx_qs = min(0.5, zx_qs)
    750         zcor = 1./(1.-retv*zx_qs)
    751         zx_qs = zx_qs*zcor
     750        zcor = 1. / (1. - retv * zx_qs)
     751        zx_qs = zx_qs * zcor
    752752        zx_gam = foede(zx_t, zdelta, zcvm5, zx_qs, zcor)
    753753        shbs(i, k) = zx_qs
    … …  
    757757        zx_p = p(i, km1)
    758758        zx_q = shb(i, km1)
    759         zdelta = max(0., sign(1.,rtt-zx_t))
    760         zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
    761         zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zx_q)
    762         zx_qs = r2es*foeew(zx_t, zdelta)/zx_p
     759        zdelta = max(0., sign(1., rtt - zx_t))
     760        zcvm5 = r5les * rlvtt * (1. - zdelta) + r5ies * rlstt * zdelta
     761        zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * zx_q)
     762        zx_qs = r2es * foeew(zx_t, zdelta) / zx_p
    763763        zx_qs = min(0.5, zx_qs)
    764         zcor = 1./(1.-retv*zx_qs)
    765         zx_qs = zx_qs*zcor
     764        zcor = 1. / (1. - retv * zx_qs)
     765        zx_qs = zx_qs * zcor
    766766        zx_gam = foede(zx_t, zdelta, zcvm5, zx_qs, zcor)
    767767        shbs(i, km1) = zx_qs
    … …  
    770770        sb(i, k) = sb(i, k) + ds2(i)
    771771        sb(i, km1) = sb(i, km1) + ds3(i)
    772         hb(i, k) = sb(i, k) + rlvtt*shb(i, k)
    773         hb(i, km1) = sb(i, km1) + rlvtt*shb(i, km1)
    774         hbs(i, k) = sb(i, k) + rlvtt*shbs(i, k)
    775         hbs(i, km1) = sb(i, km1) + rlvtt*shbs(i, km1)
    776 
    777         sbh(i, k) = 0.5*(sb(i,k)+sb(i,km1))
    778         shbh(i, k) = qhalf(shb(i,km1), shb(i,k), shbs(i,km1), shbs(i,k))
    779         hbh(i, k) = sbh(i, k) + rlvtt*shbh(i, k)
    780         sbh(i, km1) = 0.5*(sb(i,km1)+sb(i,k-2))
    781         shbh(i, km1) = qhalf(shb(i,k-2), shb(i,km1), shbs(i,k-2), &
    782           shbs(i,km1))
    783         hbh(i, km1) = sbh(i, km1) + rlvtt*shbh(i, km1)
     772        hb(i, k) = sb(i, k) + rlvtt * shb(i, k)
     773        hb(i, km1) = sb(i, km1) + rlvtt * shb(i, km1)
     774        hbs(i, k) = sb(i, k) + rlvtt * shbs(i, k)
     775        hbs(i, km1) = sb(i, km1) + rlvtt * shbs(i, km1)
     776
     777        sbh(i, k) = 0.5 * (sb(i, k) + sb(i, km1))
     778        shbh(i, k) = qhalf(shb(i, km1), shb(i, k), shbs(i, km1), shbs(i, k))
     779        hbh(i, k) = sbh(i, k) + rlvtt * shbh(i, k)
     780        sbh(i, km1) = 0.5 * (sb(i, km1) + sb(i, k - 2))
     781        shbh(i, km1) = qhalf(shb(i, k - 2), shb(i, km1), shbs(i, k - 2), &
     782                shbs(i, km1))
     783        hbh(i, km1) = sbh(i, km1) + rlvtt * shbh(i, km1)
    784784      END IF
    785785    END DO
    … …  
    789789    ! top of convective layer determined by size of overshoot param.
    790790
    791 60  CONTINUE
     791    60  CONTINUE
    792792    DO i = 1, klon
    793793      etagt0 = eta(i) > 0.0
    … …  
    803803      END IF
    804804    END DO
    805 70 END DO ! end of k loop
     805  70 END DO ! end of k loop
    806806
    807807  ! determine whether precipitation, prec, is frozen (snow) or not
    808808
    809809  DO i = 1, klon
    810     IF (tb(i,klev)<tmelt .AND. tb(i,klev-1)<tmelt) THEN
    811       cmfprs(i) = prec(i)*rdt
     810    IF (tb(i, klev)<tmelt .AND. tb(i, klev - 1)<tmelt) THEN
     811      cmfprs(i) = prec(i) * rdt
    812812    ELSE
    813       cmfprt(i) = prec(i)*rdt
     813      cmfprt(i) = prec(i) * rdt
    814814    END IF
    815815  END DO

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

    r5140 r5143  
    11SUBROUTINE concvl(iflag_clos, &
    2                   dtime, paprs, pplay, k_upper_cv, &
    3                   t, q, t_wake, q_wake, s_wake, u, v, tra, ntra, &
    4                   Ale, Alp, sig1, w01, &
    5                   d_t, d_q, d_qcomp, d_u, d_v, d_tra, &
    6                   rain, snow, kbas, ktop, sigd, &
    7                   cbmf, plcl, plfc, wbeff, convoccur, &
    8                   upwd, dnwd, dnwdbis, &
    9                   Ma, mip, Vprecip, &
    10                   cape, cin, tvp, Tconv, iflag, &
    11                   pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, dplcldr, &
    12                   qcondc, wd, pmflxr, pmflxs, &
    13 !RomP >>>
    14 !!     .             da,phi,mp,dd_t,dd_q,lalim_conv,wght_th)
    15                   da, phi, mp, phii, d1a, dam, sij, qta, clw, elij, &! RomP
    16                   dd_t, dd_q, lalim_conv, wght_th, &                 ! RomP
    17                   evap, ep, epmlmMm, eplaMm, &                       ! RomP
    18                   wdtrainA, wdtrainS, wdtrainM, wght, qtc, sigt, detrain, &
    19                   tau_cld_cv, coefw_cld_cv, &                           ! RomP+RL, AJ
    20 !RomP <<<
    21                   epmax_diag) ! epmax_cape
    22 ! **************************************************************
    23 ! *
    24 ! CONCVL                                                      *
    25 ! *
    26 ! *
    27 ! written by   : Sandrine Bony-Lena, 17/05/2003, 11.16.04    *
    28 ! modified by :                                               *
    29 ! **************************************************************
    30 
     2        dtime, paprs, pplay, k_upper_cv, &
     3        t, q, t_wake, q_wake, s_wake, u, v, tra, ntra, &
     4        Ale, Alp, sig1, w01, &
     5        d_t, d_q, d_qcomp, d_u, d_v, d_tra, &
     6        rain, snow, kbas, ktop, sigd, &
     7        cbmf, plcl, plfc, wbeff, convoccur, &
     8        upwd, dnwd, dnwdbis, &
     9        Ma, mip, Vprecip, &
     10        cape, cin, tvp, Tconv, iflag, &
     11        pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, dplcldr, &
     12        qcondc, wd, pmflxr, pmflxs, &
     13        !RomP >>>
     14        !!     .             da,phi,mp,dd_t,dd_q,lalim_conv,wght_th)
     15        da, phi, mp, phii, d1a, dam, sij, qta, clw, elij, &! RomP
     16        dd_t, dd_q, lalim_conv, wght_th, &                 ! RomP
     17        evap, ep, epmlmMm, eplaMm, &                       ! RomP
     18        wdtrainA, wdtrainS, wdtrainM, wght, qtc, sigt, detrain, &
     19        tau_cld_cv, coefw_cld_cv, &                           ! RomP+RL, AJ
     20        !RomP <<<
     21        epmax_diag) ! epmax_cape
     22  ! **************************************************************
     23  ! *
     24  ! CONCVL                                                      *
     25  ! *
     26  ! *
     27  ! written by   : Sandrine Bony-Lena, 17/05/2003, 11.16.04    *
     28  ! modified by :                                               *
     29  ! **************************************************************
    3130
    3231  USE dimphy
    … …  
    3635  USE lmdz_clesphys
    3736  USE lmdz_conema3
     37  USE lmdz_YOETHF
     38  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    3839
    3940  IMPLICIT NONE
    40 ! ======================================================================
    41 ! Auteur(s): S. Bony-Lena (LMD/CNRS) date: ???
    42 ! Objet: schema de convection de Emanuel (1991) interface
    43 ! ======================================================================
    44 ! Arguments:
    45 ! dtime--input-R-pas d'integration (s)
    46 ! s-------input-R-la vAleur "s" pour chaque couche
    47 ! sigs----input-R-la vAleur "sigma" de chaque couche
    48 ! sig-----input-R-la vAleur de "sigma" pour chaque niveau
    49 ! psolpa--input-R-la pression au sol (en Pa)
    50 ! pskapa--input-R-exponentiel kappa de psolpa
    51 ! h-------input-R-enthAlpie potentielle (Cp*T/P**kappa)
    52 ! q-------input-R-vapeur d'eau (en kg/kg)
    53 
    54 ! work*: input et output: deux variables de travail,
    55 ! on peut les mettre a 0 au debut
    56 ! ALE--------input-R-energie disponible pour soulevement
    57 ! ALP--------input-R-puissance disponible pour soulevement
    58 
    59 ! d_h--------output-R-increment de l'enthAlpie potentielle (h)
    60 ! d_q--------output-R-increment de la vapeur d'eau
    61 ! rain-------output-R-la pluie (mm/s)
    62 ! snow-------output-R-la neige (mm/s)
    63 ! upwd-------output-R-saturated updraft mass flux (kg/m**2/s)
    64 ! dnwd-------output-R-saturated downdraft mass flux (kg/m**2/s)
    65 ! dnwd0------output-R-unsaturated downdraft mass flux (kg/m**2/s)
    66 ! Ma---------output-R-adiabatic ascent mass flux (kg/m2/s)
    67 ! mip--------output-R-mass flux shed by adiabatic ascent (kg/m2/s)
    68 ! Vprecip----output-R-vertical profile of total precipitation (kg/m2/s)
    69 ! Tconv------output-R-environment temperature seen by convective scheme (K)
    70 ! Cape-------output-R-CAPE (J/kg)
    71 ! Cin -------output-R-CIN  (J/kg)
    72 ! Tvp--------output-R-Temperature virtuelle d'une parcelle soulevee
    73 ! adiabatiquement a partir du niveau 1 (K)
    74 ! deltapb----output-R-distance entre LCL et base de la colonne (<0 ; Pa)
    75 ! Ice_flag---input-L-TRUE->prise en compte de la thermodynamique de la glace
    76 ! dd_t-------output-R-increment de la temperature du aux descentes precipitantes
    77 ! dd_q-------output-R-increment de la vapeur d'eau du aux desc precip
    78 ! lalim_conv-
    79 ! wght_th----
    80 ! evap-------output-R
    81 ! ep---------output-R
    82 ! epmlmMm----output-R
    83 ! eplaMm-----output-R
    84 ! wdtrainA---output-R
    85 ! wdtrainS---output-R
    86 ! wdtrainM---output-R
    87 ! wght-------output-R
    88 ! ======================================================================
    89 
    90   INTEGER, INTENT(IN)                           :: iflag_clos
    91   REAL, INTENT(IN)                              :: dtime
    92   REAL, DIMENSION(klon,klev),   INTENT(IN)      :: pplay
    93   REAL, DIMENSION(klon,klev+1), INTENT(IN)      :: paprs
    94   INTEGER,                      INTENT(IN)      :: k_upper_cv
    95   REAL, DIMENSION(klon,klev),   INTENT(IN)      :: t, q, u, v
    96   REAL, DIMENSION(klon,klev),   INTENT(IN)      :: t_wake, q_wake
    97   REAL, DIMENSION(klon),        INTENT(IN)      :: s_wake
    98   REAL, DIMENSION(klon,klev, nbtr),INTENT(IN)  :: tra
    99   INTEGER,                      INTENT(IN)      :: ntra
    100   REAL, DIMENSION(klon),        INTENT(IN)      :: Ale, Alp
    101 !CR:test: on passe lentr et alim_star des thermiques
    102   INTEGER, DIMENSION(klon),     INTENT(IN)      :: lalim_conv
    103   REAL, DIMENSION(klon,klev),   INTENT(IN)      :: wght_th
    104 
    105   REAL, DIMENSION(klon,klev),   INTENT(INOUT)  :: sig1, w01
    106 
    107   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: d_t, d_q, d_qcomp, d_u, d_v
    108   REAL, DIMENSION(klon,klev, nbtr),INTENT(OUT) :: d_tra
    109   REAL, DIMENSION(klon),        INTENT(OUT)    :: rain, snow
    110 
    111   INTEGER, DIMENSION(klon),     INTENT(OUT)    :: kbas, ktop
    112   REAL, DIMENSION(klon),        INTENT(OUT)    :: sigd
    113   REAL, DIMENSION(klon),        INTENT(OUT)    :: cbmf, plcl, plfc, wbeff
    114   REAL, DIMENSION(klon),        INTENT(OUT)    :: convoccur
    115   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: upwd, dnwd, dnwdbis
    116 
    117 !!       REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev)                    !jyg
    118   REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: Ma, mip
    119   REAL, DIMENSION(klon,klev+1), INTENT(OUT)    :: Vprecip                        !jyg
    120   REAL, DIMENSION(klon),        INTENT(OUT)    :: cape, cin
    121   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: tvp
    122   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: Tconv
    123   INTEGER, DIMENSION(klon),     INTENT(OUT)    :: iflag
    124   REAL, DIMENSION(klon),        INTENT(OUT)    :: pbase, bbase
    125   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: dtvpdt1, dtvpdq1
    126   REAL, DIMENSION(klon),        INTENT(OUT)    :: dplcldt, dplcldr
    127   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: qcondc
    128   REAL, DIMENSION(klon),        INTENT(OUT)    :: wd
    129   REAL, DIMENSION(klon,klev+1), INTENT(OUT)    :: pmflxr, pmflxs
    130 
    131   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: da, mp
    132   REAL, DIMENSION(klon,klev,klev),INTENT(OUT)  :: phi
    133 ! RomP >>>
    134   REAL, DIMENSION(klon,klev,klev),INTENT(OUT)  :: phii
    135   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: d1a, dam
    136   REAL, DIMENSION(klon,klev,klev),INTENT(OUT)  :: sij, elij
    137   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: qta
    138   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: clw
    139   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: dd_t, dd_q
    140   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: evap, ep
    141   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: eplaMm
    142   REAL, DIMENSION(klon,klev,klev), INTENT(OUT) :: epmlmMm
    143   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: wdtrainA, wdtrainS, wdtrainM
    144 ! RomP <<<
    145   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: wght                       !RL
    146   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: qtc
    147   REAL, DIMENSION(klon,klev),   INTENT(OUT)    :: sigt, detrain
    148   REAL,                         INTENT(OUT)    :: tau_cld_cv, coefw_cld_cv
    149   REAL, DIMENSION(klon),        INTENT(OUT)    :: epmax_diag                ! epmax_cape
    150 
    151 !  Local
    152 !  ----
    153   REAL, DIMENSION(klon,klev)                    :: em_p
    154   REAL, DIMENSION(klon,klev+1)                  :: em_ph
    155   REAL                                          :: em_sig1feed ! sigma at lower bound of feeding layer
    156   REAL                                          :: em_sig2feed ! sigma at upper bound of feeding layer
    157   REAL, DIMENSION(klev)                         :: em_wght ! weight density determining the feeding mixture
    158   REAL, DIMENSION(klon,klev+1)                  :: Vprecipi                       !jyg
    159 !on enleve le save
    160 ! SAVE em_sig1feed,em_sig2feed,em_wght
    161 
    162   REAL, DIMENSION(klon)                         :: rflag
    163   REAL, DIMENSION(klon)                         :: plim1, plim2
    164   REAL, DIMENSION(klon)                         :: ptop2
    165   REAL, DIMENSION(klon,klev)                    :: asupmax
    166   REAL, DIMENSION(klon)                         :: supmax0, asupmaxmin
    167   REAL                                          :: zx_t, zdelta, zx_qs, zcor
    168 
    169 !   INTEGER iflag_mix
    170 !   SAVE iflag_mix
    171   INTEGER                                       :: noff, minorig
    172   INTEGER                                       :: i,j, k, itra
    173   REAL, DIMENSION(klon,klev)                    :: qs, qs_wake
    174 !LF          SAVE cbmf
    175 !IM/JYG      REAL, SAVE, ALLOCATABLE :: cbmf(:)
    176 !!!$OMP THREADPRIVATE(cbmf)!
    177   REAL, DIMENSION(klon)                         :: cbmflast
    178 
    179 
    180 ! Variables supplementaires liees au bilan d'energie
    181 ! Real paire(klon)
    182 !LF      Real ql(klon,klev)
    183 ! Save paire
    184 !LF      Save ql
    185 !LF      Real t1(klon,klev),q1(klon,klev)
    186 !LF      Save t1,q1
    187 ! Data paire /1./
     41  ! ======================================================================
     42  ! Auteur(s): S. Bony-Lena (LMD/CNRS) date: ???
     43  ! Objet: schema de convection de Emanuel (1991) interface
     44  ! ======================================================================
     45  ! Arguments:
     46  ! dtime--input-R-pas d'integration (s)
     47  ! s-------input-R-la vAleur "s" pour chaque couche
     48  ! sigs----input-R-la vAleur "sigma" de chaque couche
     49  ! sig-----input-R-la vAleur de "sigma" pour chaque niveau
     50  ! psolpa--input-R-la pression au sol (en Pa)
     51  ! pskapa--input-R-exponentiel kappa de psolpa
     52  ! h-------input-R-enthAlpie potentielle (Cp*T/P**kappa)
     53  ! q-------input-R-vapeur d'eau (en kg/kg)
     54
     55  ! work*: input et output: deux variables de travail,
     56  ! on peut les mettre a 0 au debut
     57  ! ALE--------input-R-energie disponible pour soulevement
     58  ! ALP--------input-R-puissance disponible pour soulevement
     59
     60  ! d_h--------output-R-increment de l'enthAlpie potentielle (h)
     61  ! d_q--------output-R-increment de la vapeur d'eau
     62  ! rain-------output-R-la pluie (mm/s)
     63  ! snow-------output-R-la neige (mm/s)
     64  ! upwd-------output-R-saturated updraft mass flux (kg/m**2/s)
     65  ! dnwd-------output-R-saturated downdraft mass flux (kg/m**2/s)
     66  ! dnwd0------output-R-unsaturated downdraft mass flux (kg/m**2/s)
     67  ! Ma---------output-R-adiabatic ascent mass flux (kg/m2/s)
     68  ! mip--------output-R-mass flux shed by adiabatic ascent (kg/m2/s)
     69  ! Vprecip----output-R-vertical profile of total precipitation (kg/m2/s)
     70  ! Tconv------output-R-environment temperature seen by convective scheme (K)
     71  ! Cape-------output-R-CAPE (J/kg)
     72  ! Cin -------output-R-CIN  (J/kg)
     73  ! Tvp--------output-R-Temperature virtuelle d'une parcelle soulevee
     74  ! adiabatiquement a partir du niveau 1 (K)
     75  ! deltapb----output-R-distance entre LCL et base de la colonne (<0 ; Pa)
     76  ! Ice_flag---input-L-TRUE->prise en compte de la thermodynamique de la glace
     77  ! dd_t-------output-R-increment de la temperature du aux descentes precipitantes
     78  ! dd_q-------output-R-increment de la vapeur d'eau du aux desc precip
     79  ! lalim_conv-
     80  ! wght_th----
     81  ! evap-------output-R
     82  ! ep---------output-R
     83  ! epmlmMm----output-R
     84  ! eplaMm-----output-R
     85  ! wdtrainA---output-R
     86  ! wdtrainS---output-R
     87  ! wdtrainM---output-R
     88  ! wght-------output-R
     89  ! ======================================================================
     90
     91  INTEGER, INTENT(IN) :: iflag_clos
     92  REAL, INTENT(IN) :: dtime
     93  REAL, DIMENSION(klon, klev), INTENT(IN) :: pplay
     94  REAL, DIMENSION(klon, klev + 1), INTENT(IN) :: paprs
     95  INTEGER, INTENT(IN) :: k_upper_cv
     96  REAL, DIMENSION(klon, klev), INTENT(IN) :: t, q, u, v
     97  REAL, DIMENSION(klon, klev), INTENT(IN) :: t_wake, q_wake
     98  REAL, DIMENSION(klon), INTENT(IN) :: s_wake
     99  REAL, DIMENSION(klon, klev, nbtr), INTENT(IN) :: tra
     100  INTEGER, INTENT(IN) :: ntra
     101  REAL, DIMENSION(klon), INTENT(IN) :: Ale, Alp
     102  !CR:test: on passe lentr et alim_star des thermiques
     103  INTEGER, DIMENSION(klon), INTENT(IN) :: lalim_conv
     104  REAL, DIMENSION(klon, klev), INTENT(IN) :: wght_th
     105
     106  REAL, DIMENSION(klon, klev), INTENT(INOUT) :: sig1, w01
     107
     108  REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_t, d_q, d_qcomp, d_u, d_v
     109  REAL, DIMENSION(klon, klev, nbtr), INTENT(OUT) :: d_tra
     110  REAL, DIMENSION(klon), INTENT(OUT) :: rain, snow
     111
     112  INTEGER, DIMENSION(klon), INTENT(OUT) :: kbas, ktop
     113  REAL, DIMENSION(klon), INTENT(OUT) :: sigd
     114  REAL, DIMENSION(klon), INTENT(OUT) :: cbmf, plcl, plfc, wbeff
     115  REAL, DIMENSION(klon), INTENT(OUT) :: convoccur
     116  REAL, DIMENSION(klon, klev), INTENT(OUT) :: upwd, dnwd, dnwdbis
     117
     118  !!       REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev)                    !jyg
     119  REAL, DIMENSION(klon, klev), INTENT(OUT) :: Ma, mip
     120  REAL, DIMENSION(klon, klev + 1), INTENT(OUT) :: Vprecip                        !jyg
     121  REAL, DIMENSION(klon), INTENT(OUT) :: cape, cin
     122  REAL, DIMENSION(klon, klev), INTENT(OUT) :: tvp
     123  REAL, DIMENSION(klon, klev), INTENT(OUT) :: Tconv
     124  INTEGER, DIMENSION(klon), INTENT(OUT) :: iflag
     125  REAL, DIMENSION(klon), INTENT(OUT) :: pbase, bbase
     126  REAL, DIMENSION(klon, klev), INTENT(OUT) :: dtvpdt1, dtvpdq1
     127  REAL, DIMENSION(klon), INTENT(OUT) :: dplcldt, dplcldr
     128  REAL, DIMENSION(klon, klev), INTENT(OUT) :: qcondc
     129  REAL, DIMENSION(klon), INTENT(OUT) :: wd
     130  REAL, DIMENSION(klon, klev + 1), INTENT(OUT) :: pmflxr, pmflxs
     131
     132  REAL, DIMENSION(klon, klev), INTENT(OUT) :: da, mp
     133  REAL, DIMENSION(klon, klev, klev), INTENT(OUT) :: phi
     134  ! RomP >>>
     135  REAL, DIMENSION(klon, klev, klev), INTENT(OUT) :: phii
     136  REAL, DIMENSION(klon, klev), INTENT(OUT) :: d1a, dam
     137  REAL, DIMENSION(klon, klev, klev), INTENT(OUT) :: sij, elij
     138  REAL, DIMENSION(klon, klev), INTENT(OUT) :: qta
     139  REAL, DIMENSION(klon, klev), INTENT(OUT) :: clw
     140  REAL, DIMENSION(klon, klev), INTENT(OUT) :: dd_t, dd_q
     141  REAL, DIMENSION(klon, klev), INTENT(OUT) :: evap, ep
     142  REAL, DIMENSION(klon, klev), INTENT(OUT) :: eplaMm
     143  REAL, DIMENSION(klon, klev, klev), INTENT(OUT) :: epmlmMm
     144  REAL, DIMENSION(klon, klev), INTENT(OUT) :: wdtrainA, wdtrainS, wdtrainM
     145  ! RomP <<<
     146  REAL, DIMENSION(klon, klev), INTENT(OUT) :: wght                       !RL
     147  REAL, DIMENSION(klon, klev), INTENT(OUT) :: qtc
     148  REAL, DIMENSION(klon, klev), INTENT(OUT) :: sigt, detrain
     149  REAL, INTENT(OUT) :: tau_cld_cv, coefw_cld_cv
     150  REAL, DIMENSION(klon), INTENT(OUT) :: epmax_diag                ! epmax_cape
     151
     152  !  Local
     153  !  ----
     154  REAL, DIMENSION(klon, klev) :: em_p
     155  REAL, DIMENSION(klon, klev + 1) :: em_ph
     156  REAL :: em_sig1feed ! sigma at lower bound of feeding layer
     157  REAL :: em_sig2feed ! sigma at upper bound of feeding layer
     158  REAL, DIMENSION(klev) :: em_wght ! weight density determining the feeding mixture
     159  REAL, DIMENSION(klon, klev + 1) :: Vprecipi                       !jyg
     160  !on enleve le save
     161  ! SAVE em_sig1feed,em_sig2feed,em_wght
     162
     163  REAL, DIMENSION(klon) :: rflag
     164  REAL, DIMENSION(klon) :: plim1, plim2
     165  REAL, DIMENSION(klon) :: ptop2
     166  REAL, DIMENSION(klon, klev) :: asupmax
     167  REAL, DIMENSION(klon) :: supmax0, asupmaxmin
     168  REAL :: zx_t, zdelta, zx_qs, zcor
     169
     170  !   INTEGER iflag_mix
     171  !   SAVE iflag_mix
     172  INTEGER :: noff, minorig
     173  INTEGER :: i, j, k, itra
     174  REAL, DIMENSION(klon, klev) :: qs, qs_wake
     175  !LF          SAVE cbmf
     176  !IM/JYG      REAL, SAVE, ALLOCATABLE :: cbmf(:)
     177  !!!$OMP THREADPRIVATE(cbmf)!
     178  REAL, DIMENSION(klon) :: cbmflast
     179
     180
     181  ! Variables supplementaires liees au bilan d'energie
     182  ! Real paire(klon)
     183  !LF      Real ql(klon,klev)
     184  ! Save paire
     185  !LF      Save ql
     186  !LF      Real t1(klon,klev),q1(klon,klev)
     187  !LF      Save t1,q1
     188  ! Data paire /1./
    188189  REAL, SAVE, ALLOCATABLE :: ql(:, :), q1(:, :), t1(:, :)
    189 !$OMP THREADPRIVATE(ql, q1, t1)
    190 
    191 ! Variables liees au bilan d'energie et d'enthAlpi
     190  !$OMP THREADPRIVATE(ql, q1, t1)
     191
     192  ! Variables liees au bilan d'energie et d'enthAlpi
    192193  REAL ztsol(klon)
    193194  REAL        h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, &
    194               h_qs_tot, qw_tot, ql_tot, qs_tot, ec_tot
     195          h_qs_tot, qw_tot, ql_tot, qs_tot, ec_tot
    195196  SAVE        h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, &
    196               h_qs_tot, qw_tot, ql_tot, qs_tot, ec_tot
    197 !$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot)
    198 !$OMP THREADPRIVATE(h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
     197          h_qs_tot, qw_tot, ql_tot, qs_tot, ec_tot
     198  !$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot)
     199  !$OMP THREADPRIVATE(h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
    199200  REAL        d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
    200201  REAL        d_h_vcol_phy
    201202  REAL        fs_bound, fq_bound
    202203  SAVE        d_h_vcol_phy
    203 !$OMP THREADPRIVATE(d_h_vcol_phy)
     204  !$OMP THREADPRIVATE(d_h_vcol_phy)
    204205  REAL        zero_v(klon)
    205206  CHARACTER *15 ztit
    … …  
    207208  SAVE        ip_ebil
    208209  DATA        ip_ebil/2/
    209 !$OMP THREADPRIVATE(ip_ebil)
     210  !$OMP THREADPRIVATE(ip_ebil)
    210211  INTEGER     if_ebil ! level for energy conserv. dignostics
    211212  SAVE        if_ebil
    212213  DATA        if_ebil/2/
    213 !$OMP THREADPRIVATE(if_ebil)
    214 !+jld ec_conser
     214  !$OMP THREADPRIVATE(if_ebil)
     215  !+jld ec_conser
    215216  REAL d_t_ec(klon, klev) ! tendance du a la conersion Ec -> E thermique
    216217  REAL zrcpd
    217 !-jld ec_conser
    218 !LF
     218  !-jld ec_conser
     219  !LF
    219220  INTEGER nloc
    220   LOGICAL, SAVE            :: first = .TRUE.
    221 !$OMP THREADPRIVATE(first)
    222   INTEGER, SAVE            :: itap, igout
    223 !$OMP THREADPRIVATE(itap, igout)
    224 
     221  LOGICAL, SAVE :: first = .TRUE.
     222  !$OMP THREADPRIVATE(first)
     223  INTEGER, SAVE :: itap, igout
     224  !$OMP THREADPRIVATE(itap, igout)
    225225
    226226  include "YOMCST.h"
    227227  include "YOMCST2.h"
    228   include "YOETHF.h"
    229   include "FCTTRE.h"
    230228
    231229  IF (first) THEN
    232 ! Allocate some variables LF 04/2008
    233 
    234 !IM/JYG allocate(cbmf(klon))
    235     ALLOCATE (ql(klon,klev))
    236     ALLOCATE (t1(klon,klev))
    237     ALLOCATE (q1(klon,klev))
     230    ! Allocate some variables LF 04/2008
     231
     232    !IM/JYG allocate(cbmf(klon))
     233    ALLOCATE (ql(klon, klev))
     234    ALLOCATE (t1(klon, klev))
     235    ALLOCATE (q1(klon, klev))
    238236
    239237    convoccur(:) = 0.
    240238
    241239    itap = 0
    242     igout = klon/2 + 1/klon
     240    igout = klon / 2 + 1 / klon
    243241  END IF
    244 ! Incrementer le compteur de la physique
     242  ! Incrementer le compteur de la physique
    245243  itap = itap + 1
    246244
    247 ! Copy T into Tconv
     245  ! Copy T into Tconv
    248246  DO k = 1, klev
    249247    DO i = 1, klon
    … …  
    262260  END IF
    263261
    264 ! ym
     262  ! ym
    265263  snow(:) = 0
    266264
    … …  
    268266    first = .FALSE.
    269267
    270 ! ===========================================================================
    271 ! READ IN PARAMETERS FOR THE CLOSURE AND THE MIXING DISTRIBUTION
    272 ! ===========================================================================
     268    ! ===========================================================================
     269    ! READ IN PARAMETERS FOR THE CLOSURE AND THE MIXING DISTRIBUTION
     270    ! ===========================================================================
    273271
    274272    IF (iflag_con==3) THEN
    275 !      CALL cv3_inicp()
     273      !      CALL cv3_inicp()
    276274      CALL cv3_inip()
    277275    END IF
    278276
    279 ! ===========================================================================
    280 ! READ IN PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
    281 ! ===========================================================================
    282 
    283 ! c$$$         open (56,file='supcrit.data')
    284 ! c$$$         read (56,*) Supcrit1, Supcrit2
    285 ! c$$$         close (56)
     277    ! ===========================================================================
     278    ! READ IN PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
     279    ! ===========================================================================
     280
     281    ! c$$$         open (56,file='supcrit.data')
     282    ! c$$$         read (56,*) Supcrit1, Supcrit2
     283    ! c$$$         close (56)
    286284
    287285    IF (prt_level>=10) WRITE (lunout, *) 'supcrit1, supcrit2', supcrit1, supcrit2
    288286
    289 ! ===========================================================================
    290 ! Initialisation pour les bilans d'eau et d'energie
    291 ! ===========================================================================
     287    ! ===========================================================================
     288    ! Initialisation pour les bilans d'eau et d'energie
     289    ! ===========================================================================
    292290    IF (if_ebil>=1) d_h_vcol_phy = 0.
    293291
    294292    DO i = 1, klon
    295293      cbmf(i) = 0.
    296 !!          plcl(i) = 0.
     294      !!          plcl(i) = 0.
    297295      sigd(i) = 0.
    298296    END DO
    299297  END IF !(first)
    300298
    301 ! Initialisation a chaque pas de temps
     299  ! Initialisation a chaque pas de temps
    302300  plfc(:) = 0.
    303301  wbeff(:) = 100.
    … …  
    306304  DO k = 1, klev + 1
    307305    DO i = 1, klon
    308       em_ph(i, k) = paprs(i, k)/100.0
     306      em_ph(i, k) = paprs(i, k) / 100.0
    309307      pmflxr(i, k) = 0.
    310308      pmflxs(i, k) = 0.
    … …  
    314312  DO k = 1, klev
    315313    DO i = 1, klon
    316       em_p(i, k) = pplay(i, k)/100.0
    317     END DO
    318   END DO
    319 
    320 
    321 ! Feeding layer
     314      em_p(i, k) = pplay(i, k) / 100.0
     315    END DO
     316  END DO
     317
     318
     319  ! Feeding layer
    322320
    323321  em_sig1feed = 1.
    324 !jyg<
    325 !  em_sig2feed = 0.97
     322  !jyg<
     323  !  em_sig2feed = 0.97
    326324  em_sig2feed = cvl_sig2feed
    327 !>jyg
    328 ! em_sig2feed = 0.8
    329 ! Relative Weight densities
     325  !>jyg
     326  ! em_sig2feed = 0.8
     327  ! Relative Weight densities
    330328  DO k = 1, klev
    331329    em_wght(k) = 1.
    332330  END DO
    333 !CRtest: couche alim des tehrmiques ponderee par a*
    334 ! DO i = 1, klon
    335 ! do k=1,lalim_conv(i)
    336 ! em_wght(k)=wght_th(i,k)
    337 ! PRINT*,'em_wght=',em_wght(k),wght_th(i,k)
    338 ! END DO
    339 ! END DO
     331  !CRtest: couche alim des tehrmiques ponderee par a*
     332  ! DO i = 1, klon
     333  ! do k=1,lalim_conv(i)
     334  ! em_wght(k)=wght_th(i,k)
     335  ! PRINT*,'em_wght=',em_wght(k),wght_th(i,k)
     336  ! END DO
     337  ! END DO
    340338
    341339  IF (iflag_con==4) THEN
    … …  
    343341      DO i = 1, klon
    344342        zx_t = t(i, k)
    345         zdelta = max(0., sign(1.,rtt-zx_t))
    346         zx_qs = min(0.5, r2es*foeew(zx_t,zdelta)/em_p(i,k)/100.0)
    347         zcor = 1./(1.-retv*zx_qs)
    348         qs(i, k) = zx_qs*zcor
     343        zdelta = max(0., sign(1., rtt - zx_t))
     344        zx_qs = min(0.5, r2es * foeew(zx_t, zdelta) / em_p(i, k) / 100.0)
     345        zcor = 1. / (1. - retv * zx_qs)
     346        qs(i, k) = zx_qs * zcor
    349347      END DO
    350348      DO i = 1, klon
    351349        zx_t = t_wake(i, k)
    352         zdelta = max(0., sign(1.,rtt-zx_t))
    353         zx_qs = min(0.5, r2es*foeew(zx_t,zdelta)/em_p(i,k)/100.0)
    354         zcor = 1./(1.-retv*zx_qs)
    355         qs_wake(i, k) = zx_qs*zcor
     350        zdelta = max(0., sign(1., rtt - zx_t))
     351        zx_qs = min(0.5, r2es * foeew(zx_t, zdelta) / em_p(i, k) / 100.0)
     352        zcor = 1. / (1. - retv * zx_qs)
     353        qs_wake(i, k) = zx_qs * zcor
    356354      END DO
    357355    END DO
    … …  
    360358      DO i = 1, klon
    361359        zx_t = t(i, k)
    362         zdelta = max(0., sign(1.,rtt-zx_t))
    363         zx_qs = r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0
     360        zdelta = max(0., sign(1., rtt - zx_t))
     361        zx_qs = r2es * foeew(zx_t, zdelta) / em_p(i, k) / 100.0
    364362        zx_qs = min(0.5, zx_qs)
    365         zcor = 1./(1.-retv*zx_qs)
    366         zx_qs = zx_qs*zcor
     363        zcor = 1. / (1. - retv * zx_qs)
     364        zx_qs = zx_qs * zcor
    367365        qs(i, k) = zx_qs
    368366      END DO
    369367      DO i = 1, klon
    370368        zx_t = t_wake(i, k)
    371         zdelta = max(0., sign(1.,rtt-zx_t))
    372         zx_qs = r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0
     369        zdelta = max(0., sign(1., rtt - zx_t))
     370        zx_qs = r2es * foeew(zx_t, zdelta) / em_p(i, k) / 100.0
    373371        zx_qs = min(0.5, zx_qs)
    374         zcor = 1./(1.-retv*zx_qs)
    375         zx_qs = zx_qs*zcor
     372        zcor = 1. / (1. - retv * zx_qs)
     373        zx_qs = zx_qs * zcor
    376374        qs_wake(i, k) = zx_qs
    377375      END DO
    … …  
    379377  END IF ! iflag_con
    380378
    381 ! ------------------------------------------------------------------
    382 
    383 ! Main driver for convection:
    384 !                   iflag_con=3 -> nvlle version de KE (JYG)
    385 !                   iflag_con = 30  -> equivAlent to convect3
    386 !                   iflag_con = 4  -> equivAlent to convect1/2
    387 
     379  ! ------------------------------------------------------------------
     380
     381  ! Main driver for convection:
     382  !                   iflag_con=3 -> nvlle version de KE (JYG)
     383  !                   iflag_con = 30  -> equivAlent to convect3
     384  !                   iflag_con = 4  -> equivAlent to convect1/2
    388385
    389386  IF (iflag_con==30) THEN
    390387
    391 ! print *, '-> cv_driver'      !jyg
     388    ! print *, '-> cv_driver'      !jyg
    392389    CALL cv_driver(klon, klev, klevp1, ntra, iflag_con, &
    393                    t, q, qs, u, v, tra, &
    394                    em_p, em_ph, iflag, &
    395                    d_t, d_q, d_u, d_v, d_tra, rain, &
    396                    Vprecip, cbmf, sig1, w01, & !jyg
    397                    kbas, ktop, &
    398                    dtime, Ma, upwd, dnwd, dnwdbis, qcondc, wd, cape, &
    399                    da, phi, mp, phii, d1a, dam, sij, clw, elij, &       !RomP
    400                    evap, ep, epmlmMm, eplaMm, &                         !RomP
    401                    wdtrainA, wdtrainM, &                                !RomP
    402                    epmax_diag) ! epmax_cape
    403 !           print *, 'cv_driver ->'      !jyg
     390            t, q, qs, u, v, tra, &
     391            em_p, em_ph, iflag, &
     392            d_t, d_q, d_u, d_v, d_tra, rain, &
     393            Vprecip, cbmf, sig1, w01, & !jyg
     394            kbas, ktop, &
     395            dtime, Ma, upwd, dnwd, dnwdbis, qcondc, wd, cape, &
     396            da, phi, mp, phii, d1a, dam, sij, clw, elij, &       !RomP
     397            evap, ep, epmlmMm, eplaMm, &                         !RomP
     398            wdtrainA, wdtrainM, &                                !RomP
     399            epmax_diag) ! epmax_cape
     400    !           print *, 'cv_driver ->'      !jyg
    404401
    405402    DO i = 1, klon
    … …  
    407404    END DO
    408405
    409 !RL
     406    !RL
    410407    wght(:, :) = 0.
    411408    DO i = 1, klon
    412409      wght(i, 1) = 1.
    413410    END DO
    414 !RL
     411    !RL
    415412
    416413  ELSE
    417414
    418 !LF   necessary for gathered fields
     415    !LF   necessary for gathered fields
    419416    nloc = klon
    420     CALL cva_driver(klon, klev, klev+1, ntra, nloc, k_upper_cv, &
    421                     iflag_con, iflag_mix, iflag_ice_thermo, &
    422                     iflag_clos, ok_conserv_q, dtime, cvl_comp_threshold, &
    423                     t, q, qs, t_wake, q_wake, qs_wake, s_wake, u, v, tra, &
    424                     em_p, em_ph, &
    425                     Ale, Alp, omega, &
    426                     em_sig1feed, em_sig2feed, em_wght, &
    427                     iflag, d_t, d_q, d_qcomp, d_u, d_v, d_tra, rain, kbas, ktop, &
    428                     cbmf, plcl, plfc, wbeff, sig1, w01, ptop2, sigd, &
    429                     Ma, mip, Vprecip, Vprecipi, upwd, dnwd, dnwdbis, qcondc, wd, &
    430                     cape, cin, tvp, &
    431                     dd_t, dd_q, plim1, plim2, asupmax, supmax0, &
    432                     asupmaxmin, lalim_conv, &
    433 !AC!+!RomP+jyg
    434 !!                   da,phi,mp,phii,d1a,dam,sij,clw,elij, &               ! RomP
    435 !!                   evap,ep,epmlmMm,eplaMm,                              ! RomP
    436                     da, phi, mp, phii, d1a, dam, sij, wght, &           ! RomP+RL
    437                     qta, clw, elij, evap, ep, epmlmMm, eplaMm, &        ! RomP+RL
    438                     wdtrainA, wdtrainS, wdtrainM, qtc, sigt, detrain, &
    439                     tau_cld_cv, coefw_cld_cv, &                         ! RomP,AJ
    440 !AC!+!RomP+jyg
    441                     epmax_diag) ! epmax_cape
     417    CALL cva_driver(klon, klev, klev + 1, ntra, nloc, k_upper_cv, &
     418            iflag_con, iflag_mix, iflag_ice_thermo, &
     419            iflag_clos, ok_conserv_q, dtime, cvl_comp_threshold, &
     420            t, q, qs, t_wake, q_wake, qs_wake, s_wake, u, v, tra, &
     421            em_p, em_ph, &
     422            Ale, Alp, omega, &
     423            em_sig1feed, em_sig2feed, em_wght, &
     424            iflag, d_t, d_q, d_qcomp, d_u, d_v, d_tra, rain, kbas, ktop, &
     425            cbmf, plcl, plfc, wbeff, sig1, w01, ptop2, sigd, &
     426            Ma, mip, Vprecip, Vprecipi, upwd, dnwd, dnwdbis, qcondc, wd, &
     427            cape, cin, tvp, &
     428            dd_t, dd_q, plim1, plim2, asupmax, supmax0, &
     429            asupmaxmin, lalim_conv, &
     430            !AC!+!RomP+jyg
     431            !!                   da,phi,mp,phii,d1a,dam,sij,clw,elij, &               ! RomP
     432            !!                   evap,ep,epmlmMm,eplaMm,                              ! RomP
     433            da, phi, mp, phii, d1a, dam, sij, wght, &           ! RomP+RL
     434            qta, clw, elij, evap, ep, epmlmMm, eplaMm, &        ! RomP+RL
     435            wdtrainA, wdtrainS, wdtrainM, qtc, sigt, detrain, &
     436            tau_cld_cv, coefw_cld_cv, &                         ! RomP,AJ
     437            !AC!+!RomP+jyg
     438            epmax_diag) ! epmax_cape
    442439  END IF
    443 ! ------------------------------------------------------------------
     440  ! ------------------------------------------------------------------
    444441  IF (prt_level>=10) WRITE (lunout, *) ' cva_driver -> cbmf,plcl,plfc,wbeff, d_t, d_q ', &
    445                                          cbmf(1), plcl(1), plfc(1), wbeff(1), d_t(1,1), d_q(1,1)
     442          cbmf(1), plcl(1), plfc(1), wbeff(1), d_t(1, 1), d_q(1, 1)
    446443
    447444  DO i = 1, klon
    448     rain(i) = rain(i)/86400.
     445    rain(i) = rain(i) / 86400.
    449446    rflag(i) = iflag(i)
    450447  END DO
    … …  
    452449  DO k = 1, klev
    453450    DO i = 1, klon
    454       d_t(i, k) = dtime*d_t(i, k)
    455       d_q(i, k) = dtime*d_q(i, k)
    456       d_u(i, k) = dtime*d_u(i, k)
    457       d_v(i, k) = dtime*d_v(i, k)
     451      d_t(i, k) = dtime * d_t(i, k)
     452      d_q(i, k) = dtime * d_q(i, k)
     453      d_u(i, k) = dtime * d_u(i, k)
     454      d_v(i, k) = dtime * d_v(i, k)
    458455    END DO
    459456  END DO
    460457
    461458  IF (iflag_con==3) THEN
    462     DO i = 1,klon
     459    DO i = 1, klon
    463460      IF (wbeff(i) > 100. .OR. wbeff(i) == 0 .OR. iflag(i) > 3) THEN
    464461        wbeff(i) = 0.
    465         convoccur(i) = 0. 
     462        convoccur(i) = 0.
    466463      ELSE
    467464        convoccur(i) = 1.
    … …  
    474471      DO k = 1, klev
    475472        DO i = 1, klon
    476 !RL!            d_tra(i,k,itra) =dtime*d_tra(i,k,itra)
     473          !RL!            d_tra(i,k,itra) =dtime*d_tra(i,k,itra)
    477474          d_tra(i, k, itra) = 0.
    478475        END DO
    … …  
    481478  END IF
    482479
    483 !!AC!
     480  !!AC!
    484481  IF (iflag_con==3) THEN
    485482    DO itra = 1, ntra
    486483      DO k = 1, klev
    487484        DO i = 1, klon
    488 !RL!            d_tra(i,k,itra) =dtime*d_tra(i,k,itra)
     485          !RL!            d_tra(i,k,itra) =dtime*d_tra(i,k,itra)
    489486          d_tra(i, k, itra) = 0.
    490487        END DO
    … …  
    492489    END DO
    493490  END IF
    494 !!AC!
     491  !!AC!
    495492
    496493  DO k = 1, klev
    … …  
    500497    END DO
    501498  END DO
    502 !                                                     !jyg
     499  !                                                     !jyg
    503500  IF (iflag_con == 30 .OR. iflag_ice_thermo ==0) THEN
    504 ! --Separation neige/pluie (pour diagnostics)         !jyg
     501    ! --Separation neige/pluie (pour diagnostics)         !jyg
    505502    DO k = 1, klev                                    !jyg
    506503      DO i = 1, klon                                  !jyg
    507         IF (t1(i,k)<rtt) THEN                         !jyg
     504        IF (t1(i, k)<rtt) THEN                         !jyg
    508505          pmflxs(i, k) = Vprecip(i, k)                !jyg
    509506        ELSE                                          !jyg
    … …  
    516513      DO i = 1, klon                                  !jyg
    517514        pmflxs(i, k) = Vprecipi(i, k)                 !jyg
    518         pmflxr(i, k) = Vprecip(i, k)-Vprecipi(i, k)   !jyg
     515        pmflxr(i, k) = Vprecip(i, k) - Vprecipi(i, k)   !jyg
    519516      END DO                                          !jyg
    520517    END DO                                            !jyg
    521518  ENDIF
    522519
    523 ! c      IF (if_ebil.ge.2) THEN
    524 ! c        ztit='after convect'
    525 ! c        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
    526 ! c     e      , t1,q1,ql,qs,u,v,paprs,pplay
    527 ! c     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
    528 ! c         CALL diagphy(paire,ztit,ip_ebil
    529 ! c     e      , zero_v, zero_v, zero_v, zero_v, zero_v
    530 ! c     e      , zero_v, rain, zero_v, ztsol
    531 ! c     e      , d_h_vcol, d_qt, d_ec
    532 ! c     s      , fs_bound, fq_bound )
    533 ! c      END IF
    534 
    535 
    536 ! les traceurs ne sont pas mis dans cette version de convect4:
     520  ! c      IF (if_ebil.ge.2) THEN
     521  ! c        ztit='after convect'
     522  ! c        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
     523  ! c     e      , t1,q1,ql,qs,u,v,paprs,pplay
     524  ! c     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
     525  ! c         CALL diagphy(paire,ztit,ip_ebil
     526  ! c     e      , zero_v, zero_v, zero_v, zero_v, zero_v
     527  ! c     e      , zero_v, rain, zero_v, ztsol
     528  ! c     e      , d_h_vcol, d_qt, d_ec
     529  ! c     s      , fs_bound, fq_bound )
     530  ! c      END IF
     531
     532
     533  ! les traceurs ne sont pas mis dans cette version de convect4:
    537534  IF (iflag_con==4) THEN
    538535    DO itra = 1, ntra
    … …  
    544541    END DO
    545542  END IF
    546 ! PRINT*, 'concvl->: dd_t,dd_q ',dd_t(1,1),dd_q(1,1)
     543  ! PRINT*, 'concvl->: dd_t,dd_q ',dd_t(1,1),dd_q(1,1)
    547544
    548545  DO k = 1, klev
    … …  
    559556  IF (prt_level>=20) THEN
    560557    DO k = 1, klev
    561 ! PRINT*,'physiq apres_add_con i k it d_u d_v d_t d_q qdl0',igout, &
    562 !         k,itap,d_u_con(igout,k) ,d_v_con(igout,k), d_t_con(igout,k), &
    563 !         d_q_con(igout,k),dql0(igout,k)
    564 ! PRINT*,'phys apres_add_con itap Ma cin ALE ALP wak t q undi t q', &
    565 !         itap,Ma(igout,k),cin(igout),ALE(igout), ALP(igout), &
    566 !         t_wake(igout,k),q_wake(igout,k),t_undi(igout,k),q_undi(igout,k)
    567 ! PRINT*,'phy apres_add_con itap CON rain snow EMA wk1 wk2 Vpp mip', &
    568 !         itap,rain_con(igout),snow_con(igout),ema_work1(igout,k), &
    569 !         ema_work2(igout,k),Vprecip(igout,k), mip(igout,k)
    570 ! PRINT*,'phy apres_add_con itap upwd dnwd dnwd0 cape tvp Tconv ', &
    571 !         itap,upwd(igout,k),dnwd(igout,k),dnwd0(igout,k),cape(igout), &
    572 !         tvp(igout,k),Tconv(igout,k)
    573 ! PRINT*,'phy apres_add_con itap dtvpdt dtvdq dplcl dplcldr qcondc', &
    574 !         itap,dtvpdt1(igout,k),dtvpdq1(igout,k),dplcldt(igout), &
    575 !         dplcldr(igout),qcondc(igout,k)
    576 ! PRINT*,'phy apres_add_con itap wd pmflxr Kpmflxr Kp1 Kpmflxs Kp1', &
    577 !         itap,wd(igout),pmflxr(igout,k),pmflxr(igout,k+1),pmflxs(igout,k), &
    578 !         pmflxs(igout,k+1)
    579 ! PRINT*,'phy apres_add_con itap da phi mp ftd fqd lalim wgth', &
    580 !         itap,da(igout,k),phi(igout,k,k),mp(igout,k),ftd(igout,k), &
    581 !         fqd(igout,k),lalim_conv(igout),wght_th(igout,k)
     558      ! PRINT*,'physiq apres_add_con i k it d_u d_v d_t d_q qdl0',igout, &
     559      !         k,itap,d_u_con(igout,k) ,d_v_con(igout,k), d_t_con(igout,k), &
     560      !         d_q_con(igout,k),dql0(igout,k)
     561      ! PRINT*,'phys apres_add_con itap Ma cin ALE ALP wak t q undi t q', &
     562      !         itap,Ma(igout,k),cin(igout),ALE(igout), ALP(igout), &
     563      !         t_wake(igout,k),q_wake(igout,k),t_undi(igout,k),q_undi(igout,k)
     564      ! PRINT*,'phy apres_add_con itap CON rain snow EMA wk1 wk2 Vpp mip', &
     565      !         itap,rain_con(igout),snow_con(igout),ema_work1(igout,k), &
     566      !         ema_work2(igout,k),Vprecip(igout,k), mip(igout,k)
     567      ! PRINT*,'phy apres_add_con itap upwd dnwd dnwd0 cape tvp Tconv ', &
     568      !         itap,upwd(igout,k),dnwd(igout,k),dnwd0(igout,k),cape(igout), &
     569      !         tvp(igout,k),Tconv(igout,k)
     570      ! PRINT*,'phy apres_add_con itap dtvpdt dtvdq dplcl dplcldr qcondc', &
     571      !         itap,dtvpdt1(igout,k),dtvpdq1(igout,k),dplcldt(igout), &
     572      !         dplcldr(igout),qcondc(igout,k)
     573      ! PRINT*,'phy apres_add_con itap wd pmflxr Kpmflxr Kp1 Kpmflxs Kp1', &
     574      !         itap,wd(igout),pmflxr(igout,k),pmflxr(igout,k+1),pmflxs(igout,k), &
     575      !         pmflxs(igout,k+1)
     576      ! PRINT*,'phy apres_add_con itap da phi mp ftd fqd lalim wgth', &
     577      !         itap,da(igout,k),phi(igout,k,k),mp(igout,k),ftd(igout,k), &
     578      !         fqd(igout,k),lalim_conv(igout),wght_th(igout,k)
    582579    END DO
    583580  END IF !(prt_level.EQ.20) THEN
    584581
    585 
    586582END SUBROUTINE concvl
    587583

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

    r5117 r5143  
    1 
    21! $Header$
    32
    43SUBROUTINE conemav(dtime, paprs, pplay, t, q, u, v, tra, ntra, work1, work2, &
    5     d_t, d_q, d_u, d_v, d_tra, rain, snow, kbas, ktop, upwd, dnwd, dnwdbis, &
    6     ma, cape, tvp, iflag, pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, dplcldr)
    7 
     4        d_t, d_q, d_u, d_v, d_tra, rain, snow, kbas, ktop, upwd, dnwd, dnwdbis, &
     5        ma, cape, tvp, iflag, pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, dplcldr)
    86
    97  USE dimphy
    108  USE infotrac_phy, ONLY: nbtr
     9  USE lmdz_YOETHF
     10  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     11
    1112  IMPLICIT NONE
    1213  ! ======================================================================
    … …  
    4243  ! ======================================================================
    4344
    44 
    45   REAL dtime, paprs(klon, klev+1), pplay(klon, klev)
     45  REAL dtime, paprs(klon, klev + 1), pplay(klon, klev)
    4646  REAL t(klon, klev), q(klon, klev), u(klon, klev), v(klon, klev)
    4747  REAL tra(klon, klev, nbtr)
    … …  
    5454
    5555  INTEGER kbas(klon), ktop(klon)
    56   REAL em_ph(klon, klev+1), em_p(klon, klev)
     56  REAL em_ph(klon, klev + 1), em_p(klon, klev)
    5757  REAL upwd(klon, klev), dnwd(klon, klev), dnwdbis(klon, klev)
    5858  REAL ma(klon, klev), cape(klon), tvp(klon, klev)
    … …  
    7575  !$OMP THREADPRIVATE(ifrst)
    7676  include "YOMCST.h"
    77   include "YOETHF.h"
    78   include "FCTTRE.h"
    79 
    8077
    8178  IF (ifrst==0) THEN
    … …  
    8986  DO k = 1, klev + 1
    9087    DO i = 1, klon
    91       em_ph(i, k) = paprs(i, k)/100.0
     88      em_ph(i, k) = paprs(i, k) / 100.0
    9289    END DO
    9390  END DO
    … …  
    9592  DO k = 1, klev
    9693    DO i = 1, klon
    97       em_p(i, k) = pplay(i, k)/100.0
     94      em_p(i, k) = pplay(i, k) / 100.0
    9895    END DO
    9996  END DO
    100 
    10197
    10298  DO k = 1, klev
    10399    DO i = 1, klon
    104100      zx_t = t(i, k)
    105       zdelta = max(0., sign(1.,rtt-zx_t))
    106       zx_qs = min(0.5, r2es*foeew(zx_t,zdelta)/em_p(i,k)/100.0)
    107       zcor = 1./(1.-retv*zx_qs)
    108       qs(i, k) = zx_qs*zcor
     101      zdelta = max(0., sign(1., rtt - zx_t))
     102      zx_qs = min(0.5, r2es * foeew(zx_t, zdelta) / em_p(i, k) / 100.0)
     103      zcor = 1. / (1. - retv * zx_qs)
     104      qs(i, k) = zx_qs * zcor
    109105    END DO
    110106  END DO
    … …  
    112108  noff = 2
    113109  minorig = 2
    114   CALL convect1(klon, klev, klev+1, noff, minorig, t, q, qs, u, v, em_p, &
    115     em_ph, iflag, d_t, d_q, d_u, d_v, rain, cbmf, dtime, ma)
     110  CALL convect1(klon, klev, klev + 1, noff, minorig, t, q, qs, u, v, em_p, &
     111          em_ph, iflag, d_t, d_q, d_u, d_v, rain, cbmf, dtime, ma)
    116112
    117113  DO i = 1, klon
    118     rain(i) = rain(i)/86400.
     114    rain(i) = rain(i) / 86400.
    119115    rflag(i) = iflag(i)
    120116  END DO
    … …  
    127123  DO k = 1, klev
    128124    DO i = 1, klon
    129       d_t(i, k) = dtime*d_t(i, k)
    130       d_q(i, k) = dtime*d_q(i, k)
    131       d_u(i, k) = dtime*d_u(i, k)
    132       d_v(i, k) = dtime*d_v(i, k)
     125      d_t(i, k) = dtime * d_t(i, k)
     126      d_q(i, k) = dtime * d_q(i, k)
     127      d_u(i, k) = dtime * d_u(i, k)
     128      d_v(i, k) = dtime * d_v(i, k)
    133129    END DO
    134130    DO itra = 1, ntra
    … …  
    139135  END DO
    140136
    141 
    142 
    143 
    144 
    145137END SUBROUTINE conemav
    146138

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

    r5140 r5143  
    4343    USE lmdz_comsoil, ONLY: inertie_sol, inertie_sno, inertie_sic, inertie_lic, iflag_sic, iflag_inertie
    4444    USE lmdz_conema3
     45    USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     46          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
    4547
    4648    INCLUDE "YOMCST.h"
    4749    INCLUDE "YOMCST2.h"
    48 
    49     !IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12
    50     INCLUDE "YOEGWD.h"
    5150
    5251    ! Configuration de la "physique" de LMDZ a l'aide de la fonction

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

    r5142 r5143  
    66
    77  USE dimphy
     8  USE lmdz_YOETHF
     9  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     10
    811  IMPLICIT NONE
    912  ! ======================================================================
    … …  
    1619  ! ======================================================================
    1720  include "YOMCST.h"
    18   include "YOETHF.h"
    1921  ! Entree:
    2022  REAL dtime ! pas d'integration (s)
    … …  
    7173  REAL zdelta, zqsat
    7274
    73   include "FCTTRE.h"
    74 
    7575  ! initialiser les variables de sortie (pour securite)
    7676  DO i = 1, klon
    … …  
    204204  USE dimphy
    205205  USE lmdz_YOECUMF
     206  USE lmdz_YOETHF
    206207
    207208  IMPLICIT NONE
    208209  ! ------------------------------------------------------------------
    209210  include "YOMCST.h"
    210   include "YOETHF.h"
    211211  ! ----------------------------------------------------------------
    212212  REAL pten(klon, klev), pqen(klon, klev), pqsen(klon, klev)
    … …  
    477477        pdmfup, pdpmel, plu, plude, klab, pen_u, pde_u, pen_d, pde_d)
    478478  USE dimphy
     479  USE lmdz_YOETHF
     480
    479481  IMPLICIT NONE
    480482  ! ----------------------------------------------------------------------
    … …  
    484486  ! ----------------------------------------------------------------------
    485487  include "YOMCST.h"
    486   include "YOETHF.h"
    487488
    488489  REAL pten(klon, klev) ! temperature (environnement)
    … …  
    598599        klab)
    599600  USE dimphy
     601  USE lmdz_YOETHF
     602
    600603  IMPLICIT NONE
    601604  ! ----------------------------------------------------------------------
    … …  
    611614  ! ----------------------------------------------------------------------
    612615  include "YOMCST.h"
    613   include "YOETHF.h"
    614616  ! ----------------------------------------------------------------
    615617  REAL ptenh(klon, klev), pqenh(klon, klev)
    … …  
    680682  USE dimphy
    681683  USE lmdz_YOECUMF
     684  USE lmdz_YOETHF
    682685
    683686  IMPLICIT NONE
    … …  
    687690  ! ----------------------------------------------------------------------
    688691  include "YOMCST.h"
    689   include "YOETHF.h"
    690692
    691693  REAL pdtime
    … …  
    981983  USE lmdz_print_control, ONLY: prt_level
    982984  USE lmdz_YOECUMF
     985  USE lmdz_YOETHF
     986  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    983987
    984988  IMPLICIT NONE
    … …  
    988992  ! ----------------------------------------------------------------------
    989993  include "YOMCST.h"
    990   include "YOETHF.h"
    991994
    992995  REAL cevapcu(klon, klev)
    … …  
    10211024  LOGICAL lddraf(klon)
    10221025  INTEGER kdtop(klon)
    1023 
    1024   include "FCTTRE.h"
    10251026
    10261027  DO k = 1, klev
    … …  
    12241225  USE dimphy
    12251226  USE lmdz_YOECUMF
     1227  USE lmdz_YOETHF
    12261228
    12271229  IMPLICIT NONE
    … …  
    12301232  ! ----------------------------------------------------------------------
    12311233  include "YOMCST.h"
    1232   include "YOETHF.h"
    12331234  ! -----------------------------------------------------------------
    12341235  LOGICAL llo1
    … …  
    12861287  USE dimphy
    12871288  USE lmdz_YOECUMF
     1289  USE lmdz_YOETHF
    12881290
    12891291  IMPLICIT NONE
    … …  
    13051307  ! ----------------------------------------------------------------------
    13061308  include "YOMCST.h"
    1307   include "YOETHF.h"
    13081309
    13091310  REAL ptenh(klon, klev)
    … …  
    13931394  USE dimphy
    13941395  USE lmdz_YOECUMF
     1396  USE lmdz_YOETHF
    13951397
    13961398  IMPLICIT NONE
    … …  
    14121414  ! ----------------------------------------------------------------------
    14131415  include "YOMCST.h"
    1414   include "YOETHF.h"
    14151416
    14161417  REAL ptenh(klon, klev), pqenh(klon, klev)
    … …  
    15061507SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall)
    15071508  USE dimphy
     1509  USE lmdz_YOETHF
     1510  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     1511
    15081512  IMPLICIT NONE
    15091513  ! ======================================================================
    … …  
    15251529  REAL zdelta, zcvm5, zldcp, zqsat, zcor
    15261530  INTEGER is, i
    1527   include "YOETHF.h"
    1528   include "FCTTRE.h"
    15291531
    15301532  z5alvcp = r5les * rlvtt / rcpd

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

    r5105 r5143  
    1 
    21! $Header$
    32
    43SUBROUTINE conlmd(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, rain, snow, &
    5     ibas, itop)
     4        ibas, itop)
    65  USE dimphy
     6  USE lmdz_YOETHF
     7
    78  IMPLICIT NONE
    89  ! ======================================================================
    … …  
    1213  ! ======================================================================
    1314  include "YOMCST.h"
    14   include "YOETHF.h"
    1515
    1616  ! Arguments:
    1717
    1818  REAL dtime ! pas d'integration (s)
    19   REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
     19  REAL paprs(klon, klev + 1) ! pression inter-couche (Pa)
    2020  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
    2121  REAL t(klon, klev) ! temperature (K)
    … …  
    3131
    3232  LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
    33   PARAMETER (usekuo=.TRUE.)
     33  PARAMETER (usekuo = .TRUE.)
    3434
    3535  REAL d_t_bis(klon, klev)
    … …  
    4747  ! cc      CALL fiajh ! ancienne version de Convection Manabe
    4848  CALL conman &                    ! nouvelle version de Convection
    49                                    ! Manabe
    50     (dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, snow, ibas, itop)
     49          ! Manabe
     50          (dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, snow, ibas, itop)
    5151
    5252  IF (usekuo) THEN
    5353    ! cc      CALL fiajc ! ancienne version de Convection Kuo
    5454    CALL conkuo &                  ! nouvelle version de Convection
    55                                    ! Kuo
    56       (dtime, paprs, pplay, t, q, conv_q, d_t_bis, d_q_bis, d_ql_bis, &
    57       rneb_bis, rain_bis, snow_bis, ibas_bis, itop_bis)
     55            ! Kuo
     56            (dtime, paprs, pplay, t, q, conv_q, d_t_bis, d_q_bis, d_ql_bis, &
     57            rneb_bis, rain_bis, snow_bis, ibas_bis, itop_bis)
    5858    DO k = 1, klev
    5959      DO i = 1, klon
    … …  
    7575  DO k = 1, klev
    7676    DO i = 1, klon
    77       zlvdcp = rlvtt/rcpd/(1.0+rvtmp2*q(i,k))
    78       zlsdcp = rlstt/rcpd/(1.0+rvtmp2*q(i,k))
    79       zdelta = max(0., sign(1.,rtt-t(i,k)))
     77      zlvdcp = rlvtt / rcpd / (1.0 + rvtmp2 * q(i, k))
     78      zlsdcp = rlstt / rcpd / (1.0 + rvtmp2 * q(i, k))
     79      zdelta = max(0., sign(1., rtt - t(i, k)))
    8080      zz = d_ql(i, k) ! re-evap. de l'eau liquide
    8181      zb = max(0.0, zz)
    82       za = -max(0.0, zz)*(zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
     82      za = -max(0.0, zz) * (zlvdcp * (1. - zdelta) + zlsdcp * zdelta)
    8383      d_t(i, k) = d_t(i, k) + za
    8484      d_q(i, k) = d_q(i, k) + zb
    … …  
    8686  END DO
    8787
    88 
    8988END SUBROUTINE conlmd
    9089SUBROUTINE conman(dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, &
    91     snow, ibas, itop)
     90        snow, ibas, itop)
    9291  USE dimphy
     92  USE lmdz_YOETHF
     93  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     94
    9395  IMPLICIT NONE
    9496  ! ======================================================================
    … …  
    108110  REAL t(klon, klev) ! temperature (K)
    109111  REAL q(klon, klev) ! humidite specifique (kg/kg)
    110   REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
     112  REAL paprs(klon, klev + 1) ! pression inter-couche (Pa)
    111113  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
    112114
    … …  
    124126
    125127  INTEGER nb ! nombre de sous-fractions a considere
    126   PARAMETER (nb=1)
     128  PARAMETER (nb = 1)
    127129  ! cc      PARAMETER (nb=3)
    128130
    129131  REAL ratqs ! largeur de la distribution pour vapeur d'eau
    130   PARAMETER (ratqs=0.05)
     132  PARAMETER (ratqs = 0.05)
    131133
    132134  REAL w_q(klon, klev)
    … …  
    139141
    140142  REAL t_coup
    141   PARAMETER (t_coup=234.0)
     143  PARAMETER (t_coup = 234.0)
    142144  REAL zdp1, zdp2
    143145  REAL zqs1, zqs2, zdqs1, zdqs2
    … …  
    163165  ! Fonctions thermodynamiques:
    164166
    165   include "YOETHF.h"
    166   include "FCTTRE.h"
    167 
    168167  DATA frac/1.0/
    169168  DATA opt_cld/4/
    … …  
    207206    DO i = 1, klon
    208207      IF (thermcep) THEN
    209         zdelta = max(0., sign(1.,rtt-t(i,k)))
    210         zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
    211         zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k))
    212         zqs1 = r2es*foeew(t(i,k), zdelta)/pplay(i, k)
     208        zdelta = max(0., sign(1., rtt - t(i, k)))
     209        zcvm5 = r5les * rlvtt * (1. - zdelta) + zdelta * r5ies * rlstt
     210        zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * q(i, k))
     211        zqs1 = r2es * foeew(t(i, k), zdelta) / pplay(i, k)
    213212        zqs1 = min(0.5, zqs1)
    214         zcor = 1./(1.-retv*zqs1)
    215         zqs1 = zqs1*zcor
    216         zdqs1 = foede(t(i,k), zdelta, zcvm5, zqs1, zcor)
    217 
    218         zdelta = max(0., sign(1.,rtt-t(i,k+1)))
    219         zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
    220         zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k+1))
    221         zqs2 = r2es*foeew(t(i,k+1), zdelta)/pplay(i, k+1)
     213        zcor = 1. / (1. - retv * zqs1)
     214        zqs1 = zqs1 * zcor
     215        zdqs1 = foede(t(i, k), zdelta, zcvm5, zqs1, zcor)
     216
     217        zdelta = max(0., sign(1., rtt - t(i, k + 1)))
     218        zcvm5 = r5les * rlvtt * (1. - zdelta) + zdelta * r5ies * rlstt
     219        zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * q(i, k + 1))
     220        zqs2 = r2es * foeew(t(i, k + 1), zdelta) / pplay(i, k + 1)
    222221        zqs2 = min(0.5, zqs2)
    223         zcor = 1./(1.-retv*zqs2)
    224         zqs2 = zqs2*zcor
    225         zdqs2 = foede(t(i,k+1), zdelta, zcvm5, zqs2, zcor)
     222        zcor = 1. / (1. - retv * zqs2)
     223        zqs2 = zqs2 * zcor
     224        zdqs2 = foede(t(i, k + 1), zdelta, zcvm5, zqs2, zcor)
    226225      ELSE
    227         IF (t(i,k)<t_coup) THEN
    228           zqs1 = qsats(t(i,k))/pplay(i, k)
    229           zdqs1 = dqsats(t(i,k), zqs1)
    230 
    231           zqs2 = qsats(t(i,k+1))/pplay(i, k+1)
    232           zdqs2 = dqsats(t(i,k+1), zqs2)
     226        IF (t(i, k)<t_coup) THEN
     227          zqs1 = qsats(t(i, k)) / pplay(i, k)
     228          zdqs1 = dqsats(t(i, k), zqs1)
     229
     230          zqs2 = qsats(t(i, k + 1)) / pplay(i, k + 1)
     231          zdqs2 = dqsats(t(i, k + 1), zqs2)
    233232        ELSE
    234           zqs1 = qsatl(t(i,k))/pplay(i, k)
    235           zdqs1 = dqsatl(t(i,k), zqs1)
    236 
    237           zqs2 = qsatl(t(i,k+1))/pplay(i, k+1)
    238           zdqs2 = dqsatl(t(i,k+1), zqs2)
    239         END IF
    240       END IF
    241       zdp1 = paprs(i, k) - paprs(i, k+1)
    242       zdp2 = paprs(i, k+1) - paprs(i, k+2)
    243       zgamdz = -(pplay(i,k)-pplay(i,k+1))/paprs(i, k+1)/rcpd*(rd*(t(i, &
    244         k)*zdp1+t(i,k+1)*zdp2)/(zdp1+zdp2)+rlvtt*(zqs1*zdp1+zqs2*zdp2)/(zdp1+ &
    245         zdp2))/(1.0+(zdqs1*zdp1+zdqs2*zdp2)/(zdp1+zdp2))
    246       zflo = t(i, k) + zgamdz - t(i, k+1)
    247       zsat = (q(i,k)-zqs1)*zdp1 + (q(i,k+1)-zqs2)*zdp2
     233          zqs1 = qsatl(t(i, k)) / pplay(i, k)
     234          zdqs1 = dqsatl(t(i, k), zqs1)
     235
     236          zqs2 = qsatl(t(i, k + 1)) / pplay(i, k + 1)
     237          zdqs2 = dqsatl(t(i, k + 1), zqs2)
     238        END IF
     239      END IF
     240      zdp1 = paprs(i, k) - paprs(i, k + 1)
     241      zdp2 = paprs(i, k + 1) - paprs(i, k + 2)
     242      zgamdz = -(pplay(i, k) - pplay(i, k + 1)) / paprs(i, k + 1) / rcpd * (rd * (t(i, &
     243              k) * zdp1 + t(i, k + 1) * zdp2) / (zdp1 + zdp2) + rlvtt * (zqs1 * zdp1 + zqs2 * zdp2) / (zdp1 + &
     244              zdp2)) / (1.0 + (zdqs1 * zdp1 + zdqs2 * zdp2) / (zdp1 + zdp2))
     245      zflo = t(i, k) + zgamdz - t(i, k + 1)
     246      zsat = (q(i, k) - zqs1) * zdp1 + (q(i, k + 1) - zqs2) * zdp2
    248247      IF (zflo>0.0) afaire(i) = .TRUE.
    249248      ! erreur         IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE.
    … …  
    257256      DO i = 1, klon
    258257        IF (afaire(i)) THEN
    259           zq1 = q(i, k)*(1.0-ratqs)
    260           zq2 = q(i, k)*(1.0+ratqs)
    261           w_q(i, k) = zq2 - frac(n)/2.0*(zq2-zq1)
     258          zq1 = q(i, k) * (1.0 - ratqs)
     259          zq2 = q(i, k) * (1.0 + ratqs)
     260          w_q(i, k) = zq2 - frac(n) / 2.0 * (zq2 - zq1)
    262261        END IF
    263262      END DO
    … …  
    265264
    266265    CALL conmanv(dtime, paprs, pplay, t, w_q, afaire, opt_cld(n), w_d_t, &
    267       w_d_q, w_d_ql, w_rneb, w_rain, w_snow, w_ibas, w_itop, accompli, &
    268       imprim)
     266            w_d_q, w_d_ql, w_rneb, w_rain, w_snow, w_ibas, w_itop, accompli, &
     267            imprim)
    269268    DO k = 1, klev
    270269      DO i = 1, klon
    271270        IF (afaire(i) .AND. accompli(i)) THEN
    272           d_t(i, k) = w_d_t(i, k)*frac(n)
    273           d_q(i, k) = w_d_q(i, k)*frac(n)
    274           d_ql(i, k) = w_d_ql(i, k)*frac(n)
    275           IF (nint(w_rneb(i,k))==1) rneb(i, k) = frac(n)
     271          d_t(i, k) = w_d_t(i, k) * frac(n)
     272          d_q(i, k) = w_d_q(i, k) * frac(n)
     273          d_ql(i, k) = w_d_ql(i, k) * frac(n)
     274          IF (nint(w_rneb(i, k))==1) rneb(i, k) = frac(n)
    276275        END IF
    277276      END DO
    … …  
    279278    DO i = 1, klon
    280279      IF (afaire(i) .AND. accompli(i)) THEN
    281         rain(i) = w_rain(i)*frac(n)
    282         snow(i) = w_snow(i)*frac(n)
     280        rain(i) = w_rain(i) * frac(n)
     281        snow(i) = w_snow(i) * frac(n)
    283282        ibas(i) = min(ibas(i), w_ibas(i))
    284283        itop(i) = max(itop(i), w_itop(i))
    … …  
    293292  ncpt = ncpt + 1
    294293
    295 
    296294END SUBROUTINE conman
    297295SUBROUTINE conmanv(dtime, paprs, pplay, t, q, afaire, opt_cld, d_t, d_q, &
    298     d_ql, rneb, rain, snow, ibas, itop, accompli, imprim)
     296        d_ql, rneb, rain, snow, ibas, itop, accompli, imprim)
    299297  USE dimphy
     298  USE lmdz_YOETHF
     299  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     300
    300301  IMPLICIT NONE
    301302  ! ======================================================================
    … …  
    313314  REAL t(klon, klev) ! temperature (K)
    314315  REAL q(klon, klev) ! humidite specifique (kg/kg)
    315   REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
     316  REAL paprs(klon, klev + 1) ! pression inter-couche (Pa)
    316317  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
    317318  INTEGER opt_cld ! comment traiter l'eau liquide
    … …  
    332333
    333334  LOGICAL new_top ! re-calculer sommet quand re-ajustement est fait
    334   PARAMETER (new_top=.FALSE.)
     335  PARAMETER (new_top = .FALSE.)
    335336  LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
    336   PARAMETER (evap_prec=.TRUE.)
     337  PARAMETER (evap_prec = .TRUE.)
    337338  REAL coef_eva
    338   PARAMETER (coef_eva=1.0E-05)
     339  PARAMETER (coef_eva = 1.0E-05)
    339340  REAL t_coup
    340   PARAMETER (t_coup=234.0)
     341  PARAMETER (t_coup = 234.0)
    341342  REAL seuil_vap
    342   PARAMETER (seuil_vap=1.0E-10)
     343  PARAMETER (seuil_vap = 1.0E-10)
    343344  LOGICAL old_tau ! implique precip nulle, si vrai.
    344   PARAMETER (old_tau=.FALSE.)
     345  PARAMETER (old_tau = .FALSE.)
    345346  REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
    346347  REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
    347   PARAMETER (dpmin=0.15, tomax=0.97)
     348  PARAMETER (dpmin = 0.15, tomax = 0.97)
    348349  REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
    349   PARAMETER (dpmax=0.30, tomin=0.05)
     350  PARAMETER (dpmax = 0.30, tomin = 0.05)
    350351  REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
    351   PARAMETER (deep_sig=0.50, deep_to=0.05)
     352  PARAMETER (deep_sig = 0.50, deep_to = 0.05)
    352353  LOGICAL exigent ! implique un calcul supplementaire pour Qs
    353   PARAMETER (exigent=.FALSE.)
     354  PARAMETER (exigent = .FALSE.)
    354355
    355356  INTEGER kbase
    356   PARAMETER (kbase=0)
     357  PARAMETER (kbase = 0)
    357358
    358359  ! Variables locales:
    … …  
    360361  INTEGER nexpo
    361362  INTEGER i, k, k1min, k1max, k2min, k2max, is
    362   REAL zgamdz(klon, klev-1)
     363  REAL zgamdz(klon, klev - 1)
    363364  REAL zt(klon, klev), zq(klon, klev)
    364365  REAL zqs(klon, klev), zdqs(klon, klev)
    … …  
    380381  ! Fonctions thermodynamiques:
    381382
    382   include "YOETHF.h"
    383   include "FCTTRE.h"
    384 
    385383  DO k = 1, klev
    386384    DO i = 1, klon
    387       delp(i, k) = paprs(i, k) - paprs(i, k+1)
     385      delp(i, k) = paprs(i, k) - paprs(i, k + 1)
    388386    END DO
    389387  END DO
    … …  
    418416
    419417        IF (thermcep) THEN
    420           zdelta = max(0., sign(1.,rtt-zt(i,k)))
    421           zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
    422           zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zq(i,k))
    423           zqs(i, k) = r2es*foeew(zt(i,k), zdelta)/pplay(i, k)
    424           zqs(i, k) = min(0.5, zqs(i,k))
    425           zcor = 1./(1.-retv*zqs(i,k))
    426           zqs(i, k) = zqs(i, k)*zcor
    427           zdqs(i, k) = foede(zt(i,k), zdelta, zcvm5, zqs(i,k), zcor)
     418          zdelta = max(0., sign(1., rtt - zt(i, k)))
     419          zcvm5 = r5les * rlvtt * (1. - zdelta) + zdelta * r5ies * rlstt
     420          zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * zq(i, k))
     421          zqs(i, k) = r2es * foeew(zt(i, k), zdelta) / pplay(i, k)
     422          zqs(i, k) = min(0.5, zqs(i, k))
     423          zcor = 1. / (1. - retv * zqs(i, k))
     424          zqs(i, k) = zqs(i, k) * zcor
     425          zdqs(i, k) = foede(zt(i, k), zdelta, zcvm5, zqs(i, k), zcor)
    428426        ELSE
    429           IF (zt(i,k)<t_coup) THEN
    430             zqs(i, k) = qsats(zt(i,k))/pplay(i, k)
    431             zdqs(i, k) = dqsats(zt(i,k), zqs(i,k))
     427          IF (zt(i, k)<t_coup) THEN
     428            zqs(i, k) = qsats(zt(i, k)) / pplay(i, k)
     429            zdqs(i, k) = dqsats(zt(i, k), zqs(i, k))
    432430          ELSE
    433             zqs(i, k) = qsatl(zt(i,k))/pplay(i, k)
    434             zdqs(i, k) = dqsatl(zt(i,k), zqs(i,k))
     431            zqs(i, k) = qsatl(zt(i, k)) / pplay(i, k)
     432            zdqs(i, k) = dqsatl(zt(i, k), zqs(i, k))
    435433          END IF
    436434        END IF
    437435
    438436        ! Calculer (q-qs)*dp
    439         zqmqsdp(i, k) = (zq(i,k)-zqs(i,k))*delp(i, k)
     437        zqmqsdp(i, k) = (zq(i, k) - zqs(i, k)) * delp(i, k)
    440438      END IF
    441439    END DO
    … …  
    450448    DO i = 1, klon
    451449      IF (afaire(i)) THEN
    452         zgamdz(i, k) = -(pplay(i,k)-pplay(i,k+1))/paprs(i, k+1)/rcpd*(rd*(zt( &
    453           i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))/(delp(i,k)+delp(i, &
    454           k+1))+rlvtt*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))/(delp(i, &
    455           k)+delp(i,k+1)))/(1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i, &
    456           k+1))/(delp(i,k)+delp(i,k+1)))
     450        zgamdz(i, k) = -(pplay(i, k) - pplay(i, k + 1)) / paprs(i, k + 1) / rcpd * (rd * (zt(&
     451                i, k) * delp(i, k) + zt(i, k + 1) * delp(i, k + 1)) / (delp(i, k) + delp(i, &
     452                k + 1)) + rlvtt * (zqs(i, k) * delp(i, k) + zqs(i, k + 1) * delp(i, k + 1)) / (delp(i, &
     453                k) + delp(i, k + 1))) / (1.0 + (zdqs(i, k) * delp(i, k) + zdqs(i, k + 1) * delp(i, &
     454                k + 1)) / (delp(i, k) + delp(i, k + 1)))
    457455      END IF
    458456    END DO
    … …  
    468466    DO i = 1, klon
    469467      IF (afaire(i)) THEN
    470         zflo(i) = zt(i, k-1) + zgamdz(i, k-1) - zt(i, k)
    471         zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k-1)
     468        zflo(i) = zt(i, k - 1) + zgamdz(i, k - 1) - zt(i, k)
     469        zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k - 1)
    472470        IF (zflo(i)>0.0 .AND. zsat(i)>0.0) possible(i) = .TRUE.
    473471      END IF
    … …  
    482480  END DO
    483481
    484 810 CONTINUE ! chercher le bas de la colonne a ajuster
     482  810 CONTINUE ! chercher le bas de la colonne a ajuster
    485483
    486484  k2min = klev
    … …  
    494492    DO i = 1, klon
    495493      IF (possible(i) .AND. k>=k2(i) .AND. aller(i)) THEN
    496         zflo(i) = zt(i, k) + zgamdz(i, k) - zt(i, k+1)
    497         zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k+1)
     494        zflo(i) = zt(i, k) + zgamdz(i, k) - zt(i, k + 1)
     495        zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k + 1)
    498496        IF (zflo(i)>0.0 .AND. zsat(i)>0.0) THEN
    499497          k1(i) = k
    … …  
    530528  ! CC      ENDDO
    531529
    532 820 CONTINUE ! chercher le haut de la colonne
     530  820 CONTINUE ! chercher le haut de la colonne
    533531
    534532  k2min = klev
    … …  
    542540        IF (todo(i) .AND. k>k2(i) .AND. aller(i)) THEN
    543541          zsat(i) = zsat(i) + zqmqsdp(i, k)
    544           zflo(i) = zt(i, k-1) + zgamdz(i, k-1) - zt(i, k)
     542          zflo(i) = zt(i, k - 1) + zgamdz(i, k - 1) - zt(i, k)
    545543          IF (zflo(i)<=0.0 .OR. zsat(i)<=0.0) THEN
    546544            aller(i) = .FALSE.
    … …  
    579577  ! CC      ENDDO
    580578
    581 830 CONTINUE ! faire l'ajustement en sachant k1 et k2
     579  830 CONTINUE ! faire l'ajustement en sachant k1 et k2
    582580
    583581  is = 0
    … …  
    608606      k = k1(i)
    609607      za(i) = 0.
    610       zb(i) = (rcpd*(1.+zdqs(i,k))*(zt(i,k)-za(i))-rlvtt*(zqs(i,k)-zq(i, &
    611         k)))*delp(i, k)
    612       zc(i) = delp(i, k)*rcpd*(1.+zdqs(i,k))
     608      zb(i) = (rcpd * (1. + zdqs(i, k)) * (zt(i, k) - za(i)) - rlvtt * (zqs(i, k) - zq(i, &
     609              k))) * delp(i, k)
     610      zc(i) = delp(i, k) * rcpd * (1. + zdqs(i, k))
    613611    END IF
    614612  END DO
    … …  
    616614  DO k = k1min, k2max
    617615    DO i = 1, klon
    618       IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) THEN
    619         za(i) = za(i) + zgamdz(i, k-1)
    620         zb(i) = zb(i) + (rcpd*(1.+zdqs(i,k))*(zt(i,k)-za(i))-rlvtt*(zqs(i, &
    621           k)-zq(i,k)))*delp(i, k)
    622         zc(i) = zc(i) + delp(i, k)*rcpd*(1.+zdqs(i,k))
     616      IF (todo(i) .AND. k>=(k1(i) + 1) .AND. k<=k2(i)) THEN
     617        za(i) = za(i) + zgamdz(i, k - 1)
     618        zb(i) = zb(i) + (rcpd * (1. + zdqs(i, k)) * (zt(i, k) - za(i)) - rlvtt * (zqs(i, &
     619                k) - zq(i, k))) * delp(i, k)
     620        zc(i) = zc(i) + delp(i, k) * rcpd * (1. + zdqs(i, k))
    623621      END IF
    624622    END DO
    … …  
    628626    IF (todo(i)) THEN
    629627      k = k1(i)
    630       ztnew(i, k) = zb(i)/zc(i)
    631       zqnew(i, k) = zqs(i, k) + (ztnew(i,k)-zt(i,k))*rcpd/rlvtt*zdqs(i, k)
     628      ztnew(i, k) = zb(i) / zc(i)
     629      zqnew(i, k) = zqs(i, k) + (ztnew(i, k) - zt(i, k)) * rcpd / rlvtt * zdqs(i, k)
    632630    END IF
    633631  END DO
    … …  
    635633  DO k = k1min, k2max
    636634    DO i = 1, klon
    637       IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) THEN
    638         ztnew(i, k) = ztnew(i, k-1) + zgamdz(i, k-1)
    639         zqnew(i, k) = zqs(i, k) + (ztnew(i,k)-zt(i,k))*rcpd/rlvtt*zdqs(i, k)
     635      IF (todo(i) .AND. k>=(k1(i) + 1) .AND. k<=k2(i)) THEN
     636        ztnew(i, k) = ztnew(i, k - 1) + zgamdz(i, k - 1)
     637        zqnew(i, k) = zqs(i, k) + (ztnew(i, k) - zt(i, k)) * rcpd / rlvtt * zdqs(i, k)
    640638      END IF
    641639    END DO
    … …  
    651649      IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) THEN
    652650        rneb(i, k) = 1.0
    653         zcond(i) = zcond(i) + (zq(i,k)-zqnew(i,k))*delp(i, k)/rg
     651        zcond(i) = zcond(i) + (zq(i, k) - zqnew(i, k)) * delp(i, k) / rg
    654652      END IF
    655653    END DO
    … …  
    680678  DO i = 1, klon
    681679    IF (todo(i)) THEN
    682       toliq(i) = tomax - ((paprs(i,k1(i))-paprs(i,k2(i)+1))/paprs(i,1)-dpmin) &
    683         *(tomax-tomin)/(dpmax-dpmin)
    684       toliq(i) = max(tomin, min(tomax,toliq(i)))
    685       IF (pplay(i,k2(i))/paprs(i,1)<=deep_sig) toliq(i) = deep_to
     680      toliq(i) = tomax - ((paprs(i, k1(i)) - paprs(i, k2(i) + 1)) / paprs(i, 1) - dpmin) &
     681              * (tomax - tomin) / (dpmax - dpmin)
     682      toliq(i) = max(tomin, min(tomax, toliq(i)))
     683      IF (pplay(i, k2(i)) / paprs(i, 1)<=deep_sig) toliq(i) = deep_to
    686684      IF (old_tau) toliq(i) = 1.0
    687685    END IF
    … …  
    706704
    707705    DO i = 1, klon
    708       IF (todo(i)) zrfl(i) = zcond(i)/dtime
     706      IF (todo(i)) zrfl(i) = zcond(i) / dtime
    709707    END DO
    710708
    … …  
    717715      DO i = 1, klon
    718716        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
    719           zqnew(i, k)*delp(i, k)/rg
     717                zqnew(i, k) * delp(i, k) / rg
    720718      END DO
    721719    END DO
    722720    DO i = 1, klon
    723721      IF (todo(i)) THEN
    724         zrapp(i) = toliq(i)*zcond(i)/zvapo(i)
    725         zrapp(i) = max(0., min(1.,zrapp(i)))
    726         zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
     722        zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
     723        zrapp(i) = max(0., min(1., zrapp(i)))
     724        zrfl(i) = (1.0 - toliq(i)) * zcond(i) / dtime
    727725      END IF
    728726    END DO
    … …  
    730728      DO i = 1, klon
    731729        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) THEN
    732           d_ql(i, k) = d_ql(i, k) + zrapp(i)*zqnew(i, k)
     730          d_ql(i, k) = d_ql(i, k) + zrapp(i) * zqnew(i, k)
    733731        END IF
    734732      END DO
    … …  
    743741      DO i = 1, klon
    744742        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
    745           delp(i, k)/rg
     743                delp(i, k) / rg
    746744      END DO
    747745    END DO
    … …  
    749747      DO i = 1, klon
    750748        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) THEN
    751           d_ql(i, k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)
    752         END IF
    753       END DO
    754     END DO
    755     DO i = 1, klon
    756       IF (todo(i)) zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
     749          d_ql(i, k) = d_ql(i, k) + toliq(i) * zcond(i) / zvapo(i)
     750        END IF
     751      END DO
     752    END DO
     753    DO i = 1, klon
     754      IF (todo(i)) zrfl(i) = (1.0 - toliq(i)) * zcond(i) / dtime
    757755    END DO
    758756
    … …  
    765763      DO i = 1, klon
    766764        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
    767           max(0.0, zq(i,k)-zqnew(i,k))*delp(i, k)/rg
     765                max(0.0, zq(i, k) - zqnew(i, k)) * delp(i, k) / rg
    768766      END DO
    769767    END DO
    … …  
    771769      DO i = 1, klon
    772770        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i) .AND. zvapo(i)>0.0) d_ql(i, &
    773           k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)*max(0.0, zq(i,k)-zqnew &
    774           (i,k))
    775       END DO
    776     END DO
    777     DO i = 1, klon
    778       IF (todo(i)) zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
     771                k) = d_ql(i, k) + toliq(i) * zcond(i) / zvapo(i) * max(0.0, zq(i, k) - zqnew &
     772                (i, k))
     773      END DO
     774    END DO
     775    DO i = 1, klon
     776      IF (todo(i)) zrfl(i) = (1.0 - toliq(i)) * zcond(i) / dtime
    779777    END DO
    780778
    … …  
    789787    DO k = k1min, k2max
    790788      DO i = 1, klon
    791         IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
    792           delp(i, k)/rg*(pplay(i,k1(i))-pplay(i,k))**nexpo
     789        IF (todo(i) .AND. k>=(k1(i) + 1) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
     790                delp(i, k) / rg * (pplay(i, k1(i)) - pplay(i, k))**nexpo
    793791      END DO
    794792    END DO
    795793    DO k = k1min, k2max
    796794      DO i = 1, klon
    797         IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) d_ql(i, k) = d_ql(i, &
    798           k) + toliq(i)*zcond(i)/zvapo(i)*(pplay(i,k1(i))-pplay(i,k))**nexpo
    799       END DO
    800     END DO
    801     DO i = 1, klon
    802       IF (todo(i)) zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
     795        IF (todo(i) .AND. k>=(k1(i) + 1) .AND. k<=k2(i)) d_ql(i, k) = d_ql(i, &
     796                k) + toliq(i) * zcond(i) / zvapo(i) * (pplay(i, k1(i)) - pplay(i, k))**nexpo
     797      END DO
     798    END DO
     799    DO i = 1, klon
     800      IF (todo(i)) zrfl(i) = (1.0 - toliq(i)) * zcond(i) / dtime
    803801    END DO
    804802
    … …  
    817815      DO i = 1, klon
    818816        IF (todo(i) .AND. k<k1(i) .AND. zrfl(i)>0.0) THEN
    819           zqev = max(0.0, (zqs(i,k)-zq(i,k))*zalfa)
    820           zqevt = coef_eva*(1.0-zq(i,k)/zqs(i,k))*sqrt(zrfl(i))*delp(i, k)/ &
    821             pplay(i, k)*zt(i, k)*rd/rg
    822           zqevt = max(0.0, min(zqevt,zrfl(i)))*rg*dtime/delp(i, k)
     817          zqev = max(0.0, (zqs(i, k) - zq(i, k)) * zalfa)
     818          zqevt = coef_eva * (1.0 - zq(i, k) / zqs(i, k)) * sqrt(zrfl(i)) * delp(i, k) / &
     819                  pplay(i, k) * zt(i, k) * rd / rg
     820          zqevt = max(0.0, min(zqevt, zrfl(i))) * rg * dtime / delp(i, k)
    823821          zqev = min(zqev, zqevt)
    824           zrfln = zrfl(i) - zqev*(delp(i,k))/rg/dtime
    825           zq(i, k) = zq(i, k) - (zrfln-zrfl(i))*(rg/(delp(i,k)))*dtime
    826           zt(i, k) = zt(i, k) + (zrfln-zrfl(i))*(rg/(delp(i, &
    827             k)))*dtime*rlvtt/rcpd/(1.0+rvtmp2*zq(i,k))
     822          zrfln = zrfl(i) - zqev * (delp(i, k)) / rg / dtime
     823          zq(i, k) = zq(i, k) - (zrfln - zrfl(i)) * (rg / (delp(i, k))) * dtime
     824          zt(i, k) = zt(i, k) + (zrfln - zrfl(i)) * (rg / (delp(i, &
     825                  k))) * dtime * rlvtt / rcpd / (1.0 + rvtmp2 * zq(i, k))
    828826          zrfl(i) = zrfln
    829827        END IF
    … …  
    836834  DO i = 1, klon
    837835    IF (todo(i)) THEN
    838       IF (zt(i,1)>rtt) THEN
     836      IF (zt(i, 1)>rtt) THEN
    839837        rain(i) = rain(i) + zrfl(i)
    840838      ELSE
    … …  
    862860        IF (todo(i)) THEN
    863861          IF (thermcep) THEN
    864             zdelta = max(0., sign(1.,rtt-zt(i,k)))
    865             zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
    866             zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zq(i,k))
    867             zqs(i, k) = r2es*foeew(zt(i,k), zdelta)/pplay(i, k)
    868             zqs(i, k) = min(0.5, zqs(i,k))
    869             zcor = 1./(1.-retv*zqs(i,k))
    870             zqs(i, k) = zqs(i, k)*zcor
    871             zdqs(i, k) = foede(zt(i,k), zdelta, zcvm5, zqs(i,k), zcor)
     862            zdelta = max(0., sign(1., rtt - zt(i, k)))
     863            zcvm5 = r5les * rlvtt * (1. - zdelta) + zdelta * r5ies * rlstt
     864            zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * zq(i, k))
     865            zqs(i, k) = r2es * foeew(zt(i, k), zdelta) / pplay(i, k)
     866            zqs(i, k) = min(0.5, zqs(i, k))
     867            zcor = 1. / (1. - retv * zqs(i, k))
     868            zqs(i, k) = zqs(i, k) * zcor
     869            zdqs(i, k) = foede(zt(i, k), zdelta, zcvm5, zqs(i, k), zcor)
    872870          ELSE
    873             IF (zt(i,k)<t_coup) THEN
    874               zqs(i, k) = qsats(zt(i,k))/pplay(i, k)
    875               zdqs(i, k) = dqsats(zt(i,k), zqs(i,k))
     871            IF (zt(i, k)<t_coup) THEN
     872              zqs(i, k) = qsats(zt(i, k)) / pplay(i, k)
     873              zdqs(i, k) = dqsats(zt(i, k), zqs(i, k))
    876874            ELSE
    877               zqs(i, k) = qsatl(zt(i,k))/pplay(i, k)
    878               zdqs(i, k) = dqsatl(zt(i,k), zqs(i,k))
     875              zqs(i, k) = qsatl(zt(i, k)) / pplay(i, k)
     876              zdqs(i, k) = dqsatl(zt(i, k), zqs(i, k))
    879877            END IF
    880878          END IF
    … …  
    888886      DO i = 1, klon
    889887        IF (todo(i)) THEN
    890           zgamdz(i, k) = -(pplay(i,k)-pplay(i,k+1))/paprs(i, k+1)/rcpd*(rd*( &
    891             zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))/(delp(i,k)+delp(i, &
    892             k+1))+rlvtt*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))/(delp(i, &
    893             k)+delp(i,k+1)))/(1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i, &
    894             k+1))/(delp(i,k)+delp(i,k+1)))
     888          zgamdz(i, k) = -(pplay(i, k) - pplay(i, k + 1)) / paprs(i, k + 1) / rcpd * (rd * (&
     889                  zt(i, k) * delp(i, k) + zt(i, k + 1) * delp(i, k + 1)) / (delp(i, k) + delp(i, &
     890                  k + 1)) + rlvtt * (zqs(i, k) * delp(i, k) + zqs(i, k + 1) * delp(i, k + 1)) / (delp(i, &
     891                  k) + delp(i, k + 1))) / (1.0 + (zdqs(i, k) * delp(i, k) + zdqs(i, k + 1) * delp(i, &
     892                  k + 1)) / (delp(i, k) + delp(i, k + 1)))
    895893        END IF
    896894      END DO
    … …  
    903901    DO i = 1, klon
    904902      IF (todo(i)) THEN
    905         zqmqsdp(i, k) = (zq(i,k)-zqs(i,k))*delp(i, k)
     903        zqmqsdp(i, k) = (zq(i, k) - zqs(i, k)) * delp(i, k)
    906904      END IF
    907905    END DO
    … …  
    916914  k1max = 1
    917915  DO i = 1, klon
    918     IF (todo(i) .AND. k1(i)>(kbase+1)) THEN
     916    IF (todo(i) .AND. k1(i)>(kbase + 1)) THEN
    919917      k = k1(i)
    920       zflo(i) = zt(i, k-1) + zgamdz(i, k-1) - zt(i, k)
    921       zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k-1)
     918      zflo(i) = zt(i, k - 1) + zgamdz(i, k - 1) - zt(i, k)
     919      zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k - 1)
    922920      ! sc voici l'ancienne ligne:
    923921      ! sc         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
    … …  
    932930  END DO
    933931
    934   IF (k1max>(kbase+1)) THEN
     932  IF (k1max>(kbase + 1)) THEN
    935933    DO k = k1max, kbase + 1, -1
    936934      DO i = 1, klon
    937935        IF (etendre(i) .AND. k<k1(i) .AND. aller(i)) THEN
    938936          zsat(i) = zsat(i) + zqmqsdp(i, k)
    939           zflo(i) = zt(i, k) + zgamdz(i, k) - zt(i, k+1)
     937          zflo(i) = zt(i, k) + zgamdz(i, k) - zt(i, k + 1)
    940938          IF (zsat(i)<=0.0 .OR. zflo(i)<=0.0) THEN
    941939            aller(i) = .FALSE.
    … …  
    999997  ! a ajuster a partir du sommet de la colonne precedente
    1000998
    1001 860 CONTINUE ! Calculer les tendances et diagnostiques
     999  860 CONTINUE ! Calculer les tendances et diagnostiques
    10021000  ! cc      PRINT*, "Apres 860"
    10031001
    … …  
    10061004      IF (accompli(i)) THEN
    10071005        d_t(i, k) = zt(i, k) - t(i, k)
    1008         zq(i, k) = max(zq(i,k), seuil_vap)
     1006        zq(i, k) = max(zq(i, k), seuil_vap)
    10091007        d_q(i, k) = zq(i, k) - q(i, k)
    10101008      END IF
    … …  
    10151013    IF (accompli(i)) THEN
    10161014      DO k = 1, klev
    1017         IF (rneb(i,k)>0.0) THEN
     1015        IF (rneb(i, k)>0.0) THEN
    10181016          ibas(i) = k
    10191017          GO TO 807
    10201018        END IF
    10211019      END DO
    1022 807   CONTINUE
     1020      807   CONTINUE
    10231021      DO k = klev, 1, -1
    1024         IF (rneb(i,k)>0.0) THEN
     1022        IF (rneb(i, k)>0.0) THEN
    10251023          itop(i) = k
    10261024          GO TO 808
    10271025        END IF
    10281026      END DO
    1029 808   CONTINUE
     1027      808   CONTINUE
    10301028    END IF
    10311029  END DO
    … …  
    10411039  END IF
    10421040
    1043 
    10441041END SUBROUTINE conmanv
    10451042SUBROUTINE conkuo(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, d_ql, rneb, &
    1046     rain, snow, ibas, itop)
     1043        rain, snow, ibas, itop)
    10471044  USE dimphy
     1045  USE lmdz_YOETHF
     1046  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     1047
    10481048  IMPLICIT NONE
    10491049  ! ======================================================================
    … …  
    10581058
    10591059  REAL dtime ! intervalle du temps (s)
    1060   REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
     1060  REAL paprs(klon, klev + 1) ! pression a inter-couche (Pa)
    10611061  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
    10621062  REAL t(klon, klev) ! temperature (K)
    … …  
    10791079
    10801080  LOGICAL calcfcl ! calculer le niveau de convection libre
    1081   PARAMETER (calcfcl=.TRUE.)
     1081  PARAMETER (calcfcl = .TRUE.)
    10821082  INTEGER ldepar ! niveau fixe de convection libre
    1083   PARAMETER (ldepar=4)
     1083  PARAMETER (ldepar = 4)
    10841084  INTEGER opt_cld ! comment traiter l'eau liquide
    1085   PARAMETER (opt_cld=4) ! valeur possible: 0, 1, 2, 3 ou 4
     1085  PARAMETER (opt_cld = 4) ! valeur possible: 0, 1, 2, 3 ou 4
    10861086  LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
    1087   PARAMETER (evap_prec=.TRUE.)
     1087  PARAMETER (evap_prec = .TRUE.)
    10881088  REAL coef_eva
    1089   PARAMETER (coef_eva=1.0E-05)
     1089  PARAMETER (coef_eva = 1.0E-05)
    10901090  LOGICAL new_deh ! nouvelle facon de calculer dH
    1091   PARAMETER (new_deh=.FALSE.)
     1091  PARAMETER (new_deh = .FALSE.)
    10921092  REAL t_coup
    1093   PARAMETER (t_coup=234.0)
     1093  PARAMETER (t_coup = 234.0)
    10941094  LOGICAL old_tau ! implique precipitation nulle
    1095   PARAMETER (old_tau=.FALSE.)
     1095  PARAMETER (old_tau = .FALSE.)
    10961096  REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
    10971097  REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
    1098   PARAMETER (dpmin=0.15, tomax=0.97)
     1098  PARAMETER (dpmin = 0.15, tomax = 0.97)
    10991099  REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
    1100   PARAMETER (dpmax=0.30, tomin=0.05)
     1100  PARAMETER (dpmax = 0.30, tomin = 0.05)
    11011101  REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
    1102   PARAMETER (deep_sig=0.50, deep_to=0.05)
     1102  PARAMETER (deep_sig = 0.50, deep_to = 0.05)
    11031103
    11041104  ! Variables locales:
    … …  
    11291129  ! Fonctions thermodynamiques
    11301130
    1131   include "YOETHF.h"
    1132   include "FCTTRE.h"
    1133 
    11341131  DATA appel1er/.TRUE./
    11351132
    … …  
    11651162    DO i = 1, klon
    11661163      IF (thermcep) THEN
    1167         zdelta = max(0., sign(1.,rtt-t(i,k)))
    1168         zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
    1169         zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k))
    1170         zqs(i, k) = r2es*foeew(t(i,k), zdelta)/pplay(i, k)
    1171         zqs(i, k) = min(0.5, zqs(i,k))
    1172         zcor = 1./(1.-retv*zqs(i,k))
    1173         zqs(i, k) = zqs(i, k)*zcor
    1174         zdqs(i, k) = foede(t(i,k), zdelta, zcvm5, zqs(i,k), zcor)
     1164        zdelta = max(0., sign(1., rtt - t(i, k)))
     1165        zcvm5 = r5les * rlvtt * (1. - zdelta) + zdelta * r5ies * rlstt
     1166        zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * q(i, k))
     1167        zqs(i, k) = r2es * foeew(t(i, k), zdelta) / pplay(i, k)
     1168        zqs(i, k) = min(0.5, zqs(i, k))
     1169        zcor = 1. / (1. - retv * zqs(i, k))
     1170        zqs(i, k) = zqs(i, k) * zcor
     1171        zdqs(i, k) = foede(t(i, k), zdelta, zcvm5, zqs(i, k), zcor)
    11751172      ELSE
    1176         IF (t(i,k)<t_coup) THEN
    1177           zqs(i, k) = qsats(t(i,k))/pplay(i, k)
    1178           zdqs(i, k) = dqsats(t(i,k), zqs(i,k))
     1173        IF (t(i, k)<t_coup) THEN
     1174          zqs(i, k) = qsats(t(i, k)) / pplay(i, k)
     1175          zdqs(i, k) = dqsats(t(i, k), zqs(i, k))
    11791176        ELSE
    1180           zqs(i, k) = qsatl(t(i,k))/pplay(i, k)
    1181           zdqs(i, k) = dqsatl(t(i,k), zqs(i,k))
     1177          zqs(i, k) = qsatl(t(i, k)) / pplay(i, k)
     1178          zdqs(i, k) = dqsatl(t(i, k), zqs(i, k))
    11821179        END IF
    11831180      END IF
    … …  
    11881185
    11891186  DO i = 1, klon
    1190     zgz(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i, &
    1191       1)))*(paprs(i,1)-pplay(i,1))
     1187    zgz(i, 1) = rd * t(i, 1) / (0.5 * (paprs(i, 1) + pplay(i, &
     1188            1))) * (paprs(i, 1) - pplay(i, 1))
    11921189  END DO
    11931190  DO k = 2, klev
    11941191    DO i = 1, klon
    1195       zgz(i, k) = zgz(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i &
    1196         ,k-1)-pplay(i,k))
     1192      zgz(i, k) = zgz(i, k - 1) + rd * 0.5 * (t(i, k - 1) + t(i, k)) / paprs(i, k) * (pplay(i &
     1193              , k - 1) - pplay(i, k))
    11971194    END DO
    11981195  END DO
    … …  
    12021199  DO k = 1, klev
    12031200    DO i = 1, klon
    1204       ztotal(i, k) = rcpd*t(i, k) + rlvtt*zqs(i, k) + zgz(i, k)
     1201      ztotal(i, k) = rcpd * t(i, k) + rlvtt * zqs(i, k) + zgz(i, k)
    12051202    END DO
    12061203  END DO
    … …  
    12221219        k = kb(i)
    12231220        IF (new_deh) THEN
    1224           zdeh(i, k) = ztotal(i, k-1) - ztotal(i, k)
     1221          zdeh(i, k) = ztotal(i, k - 1) - ztotal(i, k)
    12251222        ELSE
    1226           zdeh(i, k) = rcpd*(t(i,k-1)-t(i,k)) - rd*0.5*(t(i,k-1)+t(i,k))/ &
    1227             paprs(i, k)*(pplay(i,k-1)-pplay(i,k)) + &
    1228             rlvtt*(zqs(i,k-1)-zqs(i,k))
    1229         END IF
    1230         zdeh(i, k) = zdeh(i, k)*0.5
     1223          zdeh(i, k) = rcpd * (t(i, k - 1) - t(i, k)) - rd * 0.5 * (t(i, k - 1) + t(i, k)) / &
     1224                  paprs(i, k) * (pplay(i, k - 1) - pplay(i, k)) + &
     1225                  rlvtt * (zqs(i, k - 1) - zqs(i, k))
     1226        END IF
     1227        zdeh(i, k) = zdeh(i, k) * 0.5
    12311228      END IF
    12321229    END DO
    12331230    DO k = 1, klev
    12341231      DO i = 1, klon
    1235         IF (ldcum(i) .AND. k>=(kb(i)+1)) THEN
     1232        IF (ldcum(i) .AND. k>=(kb(i) + 1)) THEN
    12361233          IF (new_deh) THEN
    1237             zdeh(i, k) = zdeh(i, k-1) + (ztotal(i,k-1)-ztotal(i,k))
     1234            zdeh(i, k) = zdeh(i, k - 1) + (ztotal(i, k - 1) - ztotal(i, k))
    12381235          ELSE
    1239             zdeh(i, k) = zdeh(i, k-1) + rcpd*(t(i,k-1)-t(i,k)) - &
    1240               rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)* &
    1241               (pplay(i,k-1)-pplay(i,k)) + rlvtt*(zqs(i,k-1)-zqs(i,k))
     1236            zdeh(i, k) = zdeh(i, k - 1) + rcpd * (t(i, k - 1) - t(i, k)) - &
     1237                    rd * 0.5 * (t(i, k - 1) + t(i, k)) / paprs(i, k) * &
     1238                            (pplay(i, k - 1) - pplay(i, k)) + rlvtt * (zqs(i, k - 1) - zqs(i, k))
    12421239          END IF
    12431240        END IF
    … …  
    12501247      ldcum(i) = .TRUE.
    12511248      IF (new_deh) THEN
    1252         zdeh(i, k) = ztotal(i, k-1) - ztotal(i, k)
     1249        zdeh(i, k) = ztotal(i, k - 1) - ztotal(i, k)
    12531250      ELSE
    1254         zdeh(i, k) = rcpd*(t(i,k-1)-t(i,k)) - rd*0.5*(t(i,k-1)+t(i,k))/paprs( &
    1255           i, k)*(pplay(i,k-1)-pplay(i,k)) + rlvtt*(zqs(i,k-1)-zqs(i,k))
    1256       END IF
    1257       zdeh(i, k) = zdeh(i, k)*0.5
     1251        zdeh(i, k) = rcpd * (t(i, k - 1) - t(i, k)) - rd * 0.5 * (t(i, k - 1) + t(i, k)) / paprs(&
     1252                i, k) * (pplay(i, k - 1) - pplay(i, k)) + rlvtt * (zqs(i, k - 1) - zqs(i, k))
     1253      END IF
     1254      zdeh(i, k) = zdeh(i, k) * 0.5
    12581255    END DO
    12591256    DO k = ldepar + 1, klev
    12601257      DO i = 1, klon
    12611258        IF (new_deh) THEN
    1262           zdeh(i, k) = zdeh(i, k-1) + (ztotal(i,k-1)-ztotal(i,k))
     1259          zdeh(i, k) = zdeh(i, k - 1) + (ztotal(i, k - 1) - ztotal(i, k))
    12631260        ELSE
    1264           zdeh(i, k) = zdeh(i, k-1) + rcpd*(t(i,k-1)-t(i,k)) - &
    1265             rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1)-pplay(i,k)) + &
    1266             rlvtt*(zqs(i,k-1)-zqs(i,k))
     1261          zdeh(i, k) = zdeh(i, k - 1) + rcpd * (t(i, k - 1) - t(i, k)) - &
     1262                  rd * 0.5 * (t(i, k - 1) + t(i, k)) / paprs(i, k) * (pplay(i, k - 1) - pplay(i, k)) + &
     1263                  rlvtt * (zqs(i, k - 1) - zqs(i, k))
    12671264        END IF
    12681265      END DO
    … …  
    12881285        IF (nuage(i)) THEN
    12891286          kh(i) = k
    1290           zconv(i) = zconv(i) + conv_q(i, k)*dtime*(paprs(i,k)-paprs(i,k+1))
    1291           zvirt(i) = zvirt(i) + (zdeh(i,k)/rlvtt+zqs(i,k)-q(i,k))*(paprs(i,k) &
    1292             -paprs(i,k+1))
     1287          zconv(i) = zconv(i) + conv_q(i, k) * dtime * (paprs(i, k) - paprs(i, k + 1))
     1288          zvirt(i) = zvirt(i) + (zdeh(i, k) / rlvtt + zqs(i, k) - q(i, k)) * (paprs(i, k) &
     1289                  - paprs(i, k + 1))
    12931290        END IF
    12941291      END IF
    … …  
    13151312  DO i = 1, klon
    13161313    IF (todo(i)) THEN
    1317       zfrac(i) = max(0.0, min(zconv(i)/zvirt(i),1.0))
     1314      zfrac(i) = max(0.0, min(zconv(i) / zvirt(i), 1.0))
    13181315    END IF
    13191316  END DO
    … …  
    13291326    DO i = 1, klon
    13301327      IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
    1331         zvar = zdeh(i, k)/(1.+zdqs(i,k))
    1332         d_t(i, k) = zvar*zfrac(i)/rcpd
    1333         d_q(i, k) = (zvar*zdqs(i,k)/rlvtt+zqs(i,k)-q(i,k))*zfrac(i) - &
    1334           conv_q(i, k)*dtime
    1335         zcond(i) = zcond(i) - d_q(i, k)*(paprs(i,k)-paprs(i,k+1))/rg
     1328        zvar = zdeh(i, k) / (1. + zdqs(i, k))
     1329        d_t(i, k) = zvar * zfrac(i) / rcpd
     1330        d_q(i, k) = (zvar * zdqs(i, k) / rlvtt + zqs(i, k) - q(i, k)) * zfrac(i) - &
     1331                conv_q(i, k) * dtime
     1332        zcond(i) = zcond(i) - d_q(i, k) * (paprs(i, k) - paprs(i, k + 1)) / rg
    13361333        rneb(i, k) = zfrac(i)
    13371334      END IF
    … …  
    13621359  DO i = 1, klon
    13631360    IF (todo(i)) THEN
    1364       toliq(i) = tomax - ((paprs(i,kb(i))-paprs(i,kh(i)+1))/paprs(i,1)-dpmin) &
    1365         *(tomax-tomin)/(dpmax-dpmin)
    1366       toliq(i) = max(tomin, min(tomax,toliq(i)))
    1367       IF (pplay(i,kh(i))/paprs(i,1)<=deep_sig) toliq(i) = deep_to
     1361      toliq(i) = tomax - ((paprs(i, kb(i)) - paprs(i, kh(i) + 1)) / paprs(i, 1) - dpmin) &
     1362              * (tomax - tomin) / (dpmax - dpmin)
     1363      toliq(i) = max(tomin, min(tomax, toliq(i)))
     1364      IF (pplay(i, kh(i)) / paprs(i, 1)<=deep_sig) toliq(i) = deep_to
    13681365      IF (old_tau) toliq(i) = 1.0
    13691366    END IF
    … …  
    13881385
    13891386    DO i = 1, klon
    1390       IF (todo(i)) zrfl(i) = zcond(i)/dtime
     1387      IF (todo(i)) zrfl(i) = zcond(i) / dtime
    13911388    END DO
    13921389
    … …  
    13991396      DO i = 1, klon
    14001397        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
    1401           zvapo(i) = zvapo(i) + (q(i,k)+d_q(i,k))*(paprs(i,k)-paprs(i,k+1))/ &
    1402             rg
     1398          zvapo(i) = zvapo(i) + (q(i, k) + d_q(i, k)) * (paprs(i, k) - paprs(i, k + 1)) / &
     1399                  rg
    14031400        END IF
    14041401      END DO
    … …  
    14061403    DO i = 1, klon
    14071404      IF (todo(i)) THEN
    1408         zrapp(i) = toliq(i)*zcond(i)/zvapo(i)
    1409         zrapp(i) = max(0., min(1.,zrapp(i)))
     1405        zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
     1406        zrapp(i) = max(0., min(1., zrapp(i)))
    14101407      END IF
    14111408    END DO
    … …  
    14131410      DO i = 1, klon
    14141411        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
    1415           d_ql(i, k) = zrapp(i)*(q(i,k)+d_q(i,k))
     1412          d_ql(i, k) = zrapp(i) * (q(i, k) + d_q(i, k))
    14161413        END IF
    14171414      END DO
    … …  
    14191416    DO i = 1, klon
    14201417      IF (todo(i)) THEN
    1421         zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
     1418        zrfl(i) = (1.0 - toliq(i)) * zcond(i) / dtime
    14221419      END IF
    14231420    END DO
    … …  
    14311428      DO i = 1, klon
    14321429        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
    1433           zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/rg
     1430          zvapo(i) = zvapo(i) + (paprs(i, k) - paprs(i, k + 1)) / rg
    14341431        END IF
    14351432      END DO
    … …  
    14381435      DO i = 1, klon
    14391436        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
    1440           d_ql(i, k) = toliq(i)*zcond(i)/zvapo(i)
     1437          d_ql(i, k) = toliq(i) * zcond(i) / zvapo(i)
    14411438        END IF
    14421439      END DO
    … …  
    14441441    DO i = 1, klon
    14451442      IF (todo(i)) THEN
    1446         zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
     1443        zrfl(i) = (1.0 - toliq(i)) * zcond(i) / dtime
    14471444      END IF
    14481445    END DO
    … …  
    14581455      DO i = 1, klon
    14591456        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
    1460           zvapo(i) = zvapo(i) + max(0.0, -d_q(i,k))*(paprs(i,k)-paprs(i,k+1)) &
    1461             /rg
     1457          zvapo(i) = zvapo(i) + max(0.0, -d_q(i, k)) * (paprs(i, k) - paprs(i, k + 1)) &
     1458                  / rg
    14621459        END IF
    14631460      END DO
    … …  
    14661463      DO i = 1, klon
    14671464        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i) .AND. zvapo(i)>0.0) THEN
    1468           d_ql(i, k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)*max(0.0, -d_q( &
    1469             i,k))
     1465          d_ql(i, k) = d_ql(i, k) + toliq(i) * zcond(i) / zvapo(i) * max(0.0, -d_q(&
     1466                  i, k))
    14701467        END IF
    14711468      END DO
    … …  
    14731470    DO i = 1, klon
    14741471      IF (todo(i)) THEN
    1475         zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
     1472        zrfl(i) = (1.0 - toliq(i)) * zcond(i) / dtime
    14761473      END IF
    14771474    END DO
    … …  
    14891486    DO k = kbmin, khmax
    14901487      DO i = 1, klon
    1491         IF (todo(i) .AND. k>=(kb(i)+1) .AND. k<=kh(i)) THEN
    1492           zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/rg*(pplay(i,kb(i))- &
    1493             pplay(i,k))**nexpo
     1488        IF (todo(i) .AND. k>=(kb(i) + 1) .AND. k<=kh(i)) THEN
     1489          zvapo(i) = zvapo(i) + (paprs(i, k) - paprs(i, k + 1)) / rg * (pplay(i, kb(i)) - &
     1490                  pplay(i, k))**nexpo
    14941491        END IF
    14951492      END DO
    … …  
    14971494    DO k = kbmin, khmax
    14981495      DO i = 1, klon
    1499         IF (todo(i) .AND. k>=(kb(i)+1) .AND. k<=kh(i)) THEN
    1500           d_ql(i, k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)*(pplay(i,kb(i) &
    1501             )-pplay(i,k))**nexpo
     1496        IF (todo(i) .AND. k>=(kb(i) + 1) .AND. k<=kh(i)) THEN
     1497          d_ql(i, k) = d_ql(i, k) + toliq(i) * zcond(i) / zvapo(i) * (pplay(i, kb(i) &
     1498                  ) - pplay(i, k))**nexpo
    15021499        END IF
    15031500      END DO
    … …  
    15051502    DO i = 1, klon
    15061503      IF (todo(i)) THEN
    1507         zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
     1504        zrfl(i) = (1.0 - toliq(i)) * zcond(i) / dtime
    15081505      END IF
    15091506    END DO
    … …  
    15211518    DO k = kbmax, 1, -1
    15221519      DO i = 1, klon
    1523         IF (todo(i) .AND. k<=(kb(i)-1) .AND. zrfl(i)>0.0) THEN
    1524           zqev = max(0.0, (zqs(i,k)-q(i,k))*zfrac(i))
    1525           zqevt = coef_eva*(1.0-q(i,k)/zqs(i,k))*sqrt(zrfl(i))* &
    1526             (paprs(i,k)-paprs(i,k+1))/pplay(i, k)*t(i, k)*rd/rg
    1527           zqevt = max(0.0, min(zqevt,zrfl(i)))*rg*dtime/ &
    1528             (paprs(i,k)-paprs(i,k+1))
     1520        IF (todo(i) .AND. k<=(kb(i) - 1) .AND. zrfl(i)>0.0) THEN
     1521          zqev = max(0.0, (zqs(i, k) - q(i, k)) * zfrac(i))
     1522          zqevt = coef_eva * (1.0 - q(i, k) / zqs(i, k)) * sqrt(zrfl(i)) * &
     1523                  (paprs(i, k) - paprs(i, k + 1)) / pplay(i, k) * t(i, k) * rd / rg
     1524          zqevt = max(0.0, min(zqevt, zrfl(i))) * rg * dtime / &
     1525                  (paprs(i, k) - paprs(i, k + 1))
    15291526          zqev = min(zqev, zqevt)
    1530           zrfln = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))/rg/dtime
    1531           d_q(i, k) = -(zrfln-zrfl(i))*(rg/(paprs(i,k)-paprs(i,k+1)))*dtime
    1532           d_t(i, k) = (zrfln-zrfl(i))*(rg/(paprs(i,k)-paprs(i, &
    1533             k+1)))*dtime*rlvtt/rcpd
     1527          zrfln = zrfl(i) - zqev * (paprs(i, k) - paprs(i, k + 1)) / rg / dtime
     1528          d_q(i, k) = -(zrfln - zrfl(i)) * (rg / (paprs(i, k) - paprs(i, k + 1))) * dtime
     1529          d_t(i, k) = (zrfln - zrfl(i)) * (rg / (paprs(i, k) - paprs(i, &
     1530                  k + 1))) * dtime * rlvtt / rcpd
    15341531          zrfl(i) = zrfln
    15351532        END IF
    … …  
    15421539  DO i = 1, klon
    15431540    IF (todo(i)) THEN
    1544       IF (t(i,1)>rtt) THEN
     1541      IF (t(i, 1)>rtt) THEN
    15451542        rain(i) = rain(i) + zrfl(i)
    15461543      ELSE
    … …  
    15501547  END DO
    15511548
    1552 
    15531549END SUBROUTINE conkuo
    15541550SUBROUTINE kuofcl(pt, pq, pg, pp, ldcum, kcbot)
    15551551  USE dimphy
     1552  USE lmdz_YOETHF
     1553
    15561554  IMPLICIT NONE
    15571555  ! ======================================================================
    … …  
    15711569  ! ======================================================================
    15721570  include "YOMCST.h"
    1573   include "YOETHF.h"
    15741571
    15751572  REAL pt(klon, klev), pq(klon, klev), pg(klon, klev), pp(klon, klev)
    … …  
    16091606    is = 0
    16101607    DO i = 1, klon
    1611       IF (klab(i,k-1)==1) is = is + 1
     1608      IF (klab(i, k - 1)==1) is = is + 1
    16121609      lflag(i) = .FALSE.
    1613       IF (klab(i,k-1)==1) lflag(i) = .TRUE.
     1610      IF (klab(i, k - 1)==1) lflag(i) = .TRUE.
    16141611    END DO
    16151612    IF (is==0) GO TO 290
    … …  
    16191616    DO i = 1, klon
    16201617      IF (lflag(i)) THEN
    1621         zqu(i, k) = zqu(i, k-1)
    1622         ztu(i, k) = ztu(i, k-1) + (pg(i,k-1)-pg(i,k))/rcpd
    1623         zbuo = ztu(i, k)*(1.+retv*zqu(i,k)) - pt(i, k)*(1.+retv*pq(i,k)) + &
    1624           0.5
     1618        zqu(i, k) = zqu(i, k - 1)
     1619        ztu(i, k) = ztu(i, k - 1) + (pg(i, k - 1) - pg(i, k)) / rcpd
     1620        zbuo = ztu(i, k) * (1. + retv * zqu(i, k)) - pt(i, k) * (1. + retv * pq(i, k)) + &
     1621                0.5
    16251622        IF (zbuo>0.) klab(i, k) = 1
    16261623        zqold(i) = zqu(i, k)
    … …  
    16301627    ! on calcule la condensation eventuelle
    16311628
    1632     CALL adjtq(pp(1,k), ztu(1,k), zqu(1,k), lflag, 1)
     1629    CALL adjtq(pp(1, k), ztu(1, k), zqu(1, k), lflag, 1)
    16331630
    16341631    ! s'il y a la condensation et la "buoyancy" force est positive
    … …  
    16361633
    16371634    DO i = 1, klon
    1638       IF (lflag(i) .AND. zqu(i,k)/=zqold(i)) THEN
     1635      IF (lflag(i) .AND. zqu(i, k)/=zqold(i)) THEN
    16391636        klab(i, k) = 2
    16401637        zlu(i, k) = zlu(i, k) + zqold(i) - zqu(i, k)
    1641         zbuo = ztu(i, k)*(1.+retv*zqu(i,k)) - pt(i, k)*(1.+retv*pq(i,k)) + &
    1642           0.5
     1638        zbuo = ztu(i, k) * (1. + retv * zqu(i, k)) - pt(i, k) * (1. + retv * pq(i, k)) + &
     1639                0.5
    16431640        IF (zbuo>0.) THEN
    16441641          kcbot(i) = k
    … …  
    16481645    END DO
    16491646
    1650 290 END DO
    1651 
     1647  290 END DO
    16521648
    16531649END SUBROUTINE kuofcl
    16541650SUBROUTINE adjtq(pp, pt, pq, ldflag, kcall)
    16551651  USE dimphy
     1652  USE lmdz_YOETHF
     1653  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     1654
    16561655  IMPLICIT NONE
    16571656  ! ======================================================================
    … …  
    16791678
    16801679  REAL t_coup
    1681   PARAMETER (t_coup=234.0)
     1680  PARAMETER (t_coup = 234.0)
    16821681
    16831682  REAL zcond(klon), zcond1
    16841683  REAL zdelta, zcvm5, zldcp, zqsat, zcor, zdqsat
    16851684  INTEGER is, i
    1686   include "YOETHF.h"
    1687   include "FCTTRE.h"
    16881685
    16891686  DO i = 1, klon
    … …  
    16931690  DO i = 1, klon
    16941691    IF (ldflag(i)) THEN
    1695       zdelta = max(0., sign(1.,rtt-pt(i)))
    1696       zldcp = rlvtt*(1.-zdelta) + zdelta*rlstt
    1697       zldcp = zldcp/rcpd/(1.0+rvtmp2*pq(i))
     1692      zdelta = max(0., sign(1., rtt - pt(i)))
     1693      zldcp = rlvtt * (1. - zdelta) + zdelta * rlstt
     1694      zldcp = zldcp / rcpd / (1.0 + rvtmp2 * pq(i))
    16981695      IF (thermcep) THEN
    1699         zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
    1700         zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*pq(i))
    1701         zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
     1696        zcvm5 = r5les * rlvtt * (1. - zdelta) + zdelta * r5ies * rlstt
     1697        zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * pq(i))
     1698        zqsat = r2es * foeew(pt(i), zdelta) / pp(i)
    17021699        zqsat = min(0.5, zqsat)
    1703         zcor = 1./(1.-retv*zqsat)
    1704         zqsat = zqsat*zcor
     1700        zcor = 1. / (1. - retv * zqsat)
     1701        zqsat = zqsat * zcor
    17051702        zdqsat = foede(pt(i), zdelta, zcvm5, zqsat, zcor)
    17061703      ELSE
    17071704        IF (pt(i)<t_coup) THEN
    1708           zqsat = qsats(pt(i))/pp(i)
     1705          zqsat = qsats(pt(i)) / pp(i)
    17091706          zdqsat = dqsats(pt(i), zqsat)
    17101707        ELSE
    1711           zqsat = qsatl(pt(i))/pp(i)
     1708          zqsat = qsatl(pt(i)) / pp(i)
    17121709          zdqsat = dqsatl(pt(i), zqsat)
    17131710        END IF
    17141711      END IF
    1715       zcond(i) = (pq(i)-zqsat)/(1.+zdqsat)
     1712      zcond(i) = (pq(i) - zqsat) / (1. + zdqsat)
    17161713      IF (kcall==1) zcond(i) = max(zcond(i), 0.)
    17171714      IF (kcall==2) zcond(i) = min(zcond(i), 0.)
    1718       pt(i) = pt(i) + zldcp*zcond(i)
     1715      pt(i) = pt(i) + zldcp * zcond(i)
    17191716      pq(i) = pq(i) - zcond(i)
    17201717    END IF
    … …  
    17291726  DO i = 1, klon
    17301727    IF (ldflag(i) .AND. zcond(i)/=0.) THEN
    1731       zdelta = max(0., sign(1.,rtt-pt(i)))
    1732       zldcp = rlvtt*(1.-zdelta) + zdelta*rlstt
    1733       zldcp = zldcp/rcpd/(1.0+rvtmp2*pq(i))
     1728      zdelta = max(0., sign(1., rtt - pt(i)))
     1729      zldcp = rlvtt * (1. - zdelta) + zdelta * rlstt
     1730      zldcp = zldcp / rcpd / (1.0 + rvtmp2 * pq(i))
    17341731      IF (thermcep) THEN
    1735         zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
    1736         zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*pq(i))
    1737         zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
     1732        zcvm5 = r5les * rlvtt * (1. - zdelta) + zdelta * r5ies * rlstt
     1733        zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * pq(i))
     1734        zqsat = r2es * foeew(pt(i), zdelta) / pp(i)
    17381735        zqsat = min(0.5, zqsat)
    1739         zcor = 1./(1.-retv*zqsat)
    1740         zqsat = zqsat*zcor
     1736        zcor = 1. / (1. - retv * zqsat)
     1737        zqsat = zqsat * zcor
    17411738        zdqsat = foede(pt(i), zdelta, zcvm5, zqsat, zcor)
    17421739      ELSE
    17431740        IF (pt(i)<t_coup) THEN
    1744           zqsat = qsats(pt(i))/pp(i)
     1741          zqsat = qsats(pt(i)) / pp(i)
    17451742          zdqsat = dqsats(pt(i), zqsat)
    17461743        ELSE
    1747           zqsat = qsatl(pt(i))/pp(i)
     1744          zqsat = qsatl(pt(i)) / pp(i)
    17481745          zdqsat = dqsatl(pt(i), zqsat)
    17491746        END IF
    17501747      END IF
    1751       zcond1 = (pq(i)-zqsat)/(1.+zdqsat)
    1752       pt(i) = pt(i) + zldcp*zcond1
     1748      zcond1 = (pq(i) - zqsat) / (1. + zdqsat)
     1749      pt(i) = pt(i) + zldcp * zcond1
    17531750      pq(i) = pq(i) - zcond1
    17541751    END IF
    17551752  END DO
    17561753
    1757 230 CONTINUE
     1754  230 CONTINUE
    17581755
    17591756END SUBROUTINE adjtq
    17601757SUBROUTINE fiajh(dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, snow, &
    1761     ibas, itop)
     1758        ibas, itop)
    17621759  USE dimphy
     1760  USE lmdz_YOETHF
     1761  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     1762
    17631763  IMPLICIT NONE
    17641764
    … …  
    17721772  REAL t(klon, klev) ! temperature (K)
    17731773  REAL q(klon, klev) ! humidite specifique (kg/kg)
    1774   REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
     1774  REAL paprs(klon, klev + 1) ! pression a inter-couche (Pa)
    17751775  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
    17761776
    … …  
    17861786
    17871787  REAL t_coup
    1788   PARAMETER (t_coup=234.0)
     1788  PARAMETER (t_coup = 234.0)
    17891789  REAL seuil_vap
    1790   PARAMETER (seuil_vap=1.0E-10)
     1790  PARAMETER (seuil_vap = 1.0E-10)
    17911791
    17921792  ! Variables locales:
    … …  
    18131813  REAL zdelta, zcor, zcvm5
    18141814
    1815   include "YOETHF.h"
    1816   include "FCTTRE.h"
    1817 
    18181815  DO k = 1, klev
    18191816    DO i = 1, klon
    … …  
    18371834  DO k = 1, klev
    18381835    DO i = 1, klon
    1839       v_cptt(i, k) = rcpd*local_t(i, k)
     1836      v_cptt(i, k) = rcpd * local_t(i, k)
    18401837      v_t = local_t(i, k)
    18411838      v_p = pplay(i, k)
    18421839
    18431840      IF (thermcep) THEN
    1844         zdelta = max(0., sign(1.,rtt-v_t))
    1845         zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
    1846         zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*local_q(i,k))
    1847         v_qs(i, k) = r2es*foeew(v_t, zdelta)/v_p
    1848         v_qs(i, k) = min(0.5, v_qs(i,k))
    1849         zcor = 1./(1.-retv*v_qs(i,k))
    1850         v_qs(i, k) = v_qs(i, k)*zcor
    1851         v_qsd(i, k) = foede(v_t, zdelta, zcvm5, v_qs(i,k), zcor)
     1841        zdelta = max(0., sign(1., rtt - v_t))
     1842        zcvm5 = r5les * rlvtt * (1. - zdelta) + zdelta * r5ies * rlstt
     1843        zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * local_q(i, k))
     1844        v_qs(i, k) = r2es * foeew(v_t, zdelta) / v_p
     1845        v_qs(i, k) = min(0.5, v_qs(i, k))
     1846        zcor = 1. / (1. - retv * v_qs(i, k))
     1847        v_qs(i, k) = v_qs(i, k) * zcor
     1848        v_qsd(i, k) = foede(v_t, zdelta, zcvm5, v_qs(i, k), zcor)
    18521849      ELSE
    18531850        IF (v_t<t_coup) THEN
    1854           v_qs(i, k) = qsats(v_t)/v_p
    1855           v_qsd(i, k) = dqsats(v_t, v_qs(i,k))
     1851          v_qs(i, k) = qsats(v_t) / v_p
     1852          v_qsd(i, k) = dqsats(v_t, v_qs(i, k))
    18561853        ELSE
    1857           v_qs(i, k) = qsatl(v_t)/v_p
    1858           v_qsd(i, k) = dqsatl(v_t, v_qs(i,k))
     1854          v_qs(i, k) = qsatl(v_t) / v_p
     1855          v_qsd(i, k) = dqsatl(v_t, v_qs(i, k))
    18591856        END IF
    18601857      END IF
    … …  
    18661863  DO k = 2, klev
    18671864    DO i = 1, klon
    1868       zdp = paprs(i, k) - paprs(i, k+1)
    1869       zdpm = paprs(i, k-1) - paprs(i, k)
    1870       gamcpdz(i, k) = ((rd/rcpd/(zdpm+zdp)*(v_cptt(i,k-1)*zdpm+ &
    1871         v_cptt(i,k)*zdp)+rlvtt/(zdpm+zdp)*(v_qs(i,k-1)*zdpm+ &
    1872         v_qs(i,k)*zdp))*(pplay(i,k-1)-pplay(i,k))/paprs(i,k))/(1.0+(v_qsd(i, &
    1873         k-1)*zdpm+v_qsd(i,k)*zdp)/(zdpm+zdp))
     1865      zdp = paprs(i, k) - paprs(i, k + 1)
     1866      zdpm = paprs(i, k - 1) - paprs(i, k)
     1867      gamcpdz(i, k) = ((rd / rcpd / (zdpm + zdp) * (v_cptt(i, k - 1) * zdpm + &
     1868              v_cptt(i, k) * zdp) + rlvtt / (zdpm + zdp) * (v_qs(i, k - 1) * zdpm + &
     1869              v_qs(i, k) * zdp)) * (pplay(i, k - 1) - pplay(i, k)) / paprs(i, k)) / (1.0 + (v_qsd(i, &
     1870              k - 1) * zdpm + v_qsd(i, k) * zdp) / (zdpm + zdp))
    18741871    END DO
    18751872  END DO
    … …  
    18821879    k2 = 1
    18831880
    1884 810 CONTINUE ! chercher k1, le bas de la colonne
     1881    810 CONTINUE ! chercher k1, le bas de la colonne
    18851882    k2 = k2 + 1
    18861883    IF (k2>klev) GO TO 9999
    1887     zflo = v_cptt(i, k2-1) - v_cptt(i, k2) - gamcpdz(i, k2)
    1888     zsat = (local_q(i,k2-1)-v_qs(i,k2-1))*(paprs(i,k2-1)-paprs(i,k2)) + &
    1889       (local_q(i,k2)-v_qs(i,k2))*(paprs(i,k2)-paprs(i,k2+1))
     1884    zflo = v_cptt(i, k2 - 1) - v_cptt(i, k2) - gamcpdz(i, k2)
     1885    zsat = (local_q(i, k2 - 1) - v_qs(i, k2 - 1)) * (paprs(i, k2 - 1) - paprs(i, k2)) + &
     1886            (local_q(i, k2) - v_qs(i, k2)) * (paprs(i, k2) - paprs(i, k2 + 1))
    18901887    IF (zflo<=0.0 .OR. zsat<=0.0) GO TO 810
    18911888    k1 = k2 - 1
    18921889    itest(i) = .TRUE.
    18931890
    1894 820 CONTINUE ! chercher k2, le haut de la colonne
     1891    820 CONTINUE ! chercher k2, le haut de la colonne
    18951892    IF (k2==klev) GO TO 821
    18961893    k2p = k2 + 1
    1897     zsat = zsat + (paprs(i,k2p)-paprs(i,k2p+1))*(local_q(i,k2p)-v_qs(i,k2p))
    1898     zflo = v_cptt(i, k2p-1) - v_cptt(i, k2p) - gamcpdz(i, k2p)
     1894    zsat = zsat + (paprs(i, k2p) - paprs(i, k2p + 1)) * (local_q(i, k2p) - v_qs(i, k2p))
     1895    zflo = v_cptt(i, k2p - 1) - v_cptt(i, k2p) - gamcpdz(i, k2p)
    18991896    IF (zflo<=0.0 .OR. zsat<=0.0) GO TO 821
    19001897    k2 = k2p
    19011898    GO TO 820
    1902 821 CONTINUE
     1899    821 CONTINUE
    19031900
    19041901    ! ------------------------------------------------------ ajustement local
    1905 830 CONTINUE ! ajustement proprement dit
     1902    830 CONTINUE ! ajustement proprement dit
    19061903    v_cptj(k1) = 0.0
    1907     zdp = paprs(i, k1) - paprs(i, k1+1)
    1908     v_cptjk1 = ((1.0+v_qsd(i,k1))*(v_cptt(i,k1)+v_cptj(k1))+rlvtt*(local_q(i, &
    1909       k1)-v_qs(i,k1)))*zdp
    1910     v_ssig = zdp*(1.0+v_qsd(i,k1))
     1904    zdp = paprs(i, k1) - paprs(i, k1 + 1)
     1905    v_cptjk1 = ((1.0 + v_qsd(i, k1)) * (v_cptt(i, k1) + v_cptj(k1)) + rlvtt * (local_q(i, &
     1906            k1) - v_qs(i, k1))) * zdp
     1907    v_ssig = zdp * (1.0 + v_qsd(i, k1))
    19111908
    19121909    k1p = k1 + 1
    19131910    DO k = k1p, k2
    1914       zdp = paprs(i, k) - paprs(i, k+1)
    1915       v_cptj(k) = v_cptj(k-1) + gamcpdz(i, k)
    1916       v_cptjk1 = v_cptjk1 + zdp*((1.0+v_qsd(i,k))*(v_cptt(i, &
    1917         k)+v_cptj(k))+rlvtt*(local_q(i,k)-v_qs(i,k)))
    1918       v_ssig = v_ssig + zdp*(1.0+v_qsd(i,k))
     1911      zdp = paprs(i, k) - paprs(i, k + 1)
     1912      v_cptj(k) = v_cptj(k - 1) + gamcpdz(i, k)
     1913      v_cptjk1 = v_cptjk1 + zdp * ((1.0 + v_qsd(i, k)) * (v_cptt(i, &
     1914              k) + v_cptj(k)) + rlvtt * (local_q(i, k) - v_qs(i, k)))
     1915      v_ssig = v_ssig + zdp * (1.0 + v_qsd(i, k))
    19191916    END DO
    19201917
    19211918    DO k = k1, k2
    1922       cp_new_t(k) = v_cptjk1/v_ssig - v_cptj(k)
     1919      cp_new_t(k) = v_cptjk1 / v_ssig - v_cptj(k)
    19231920      cp_delta_t(k) = cp_new_t(k) - v_cptt(i, k)
    1924       new_qb(k) = v_qs(i, k) + v_qsd(i, k)*cp_delta_t(k)/rlvtt
     1921      new_qb(k) = v_qs(i, k) + v_qsd(i, k) * cp_delta_t(k) / rlvtt
    19251922      local_q(i, k) = new_qb(k)
    1926       local_t(i, k) = cp_new_t(k)/rcpd
     1923      local_t(i, k) = cp_new_t(k) / rcpd
    19271924    END DO
    19281925
    … …  
    19321929
    19331930    DO k = k1, k2
    1934       v_cptt(i, k) = rcpd*local_t(i, k)
     1931      v_cptt(i, k) = rcpd * local_t(i, k)
    19351932      v_t = local_t(i, k)
    19361933      v_p = pplay(i, k)
    19371934
    19381935      IF (thermcep) THEN
    1939         zdelta = max(0., sign(1.,rtt-v_t))
    1940         zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
    1941         zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*local_q(i,k))
    1942         v_qs(i, k) = r2es*foeew(v_t, zdelta)/v_p
    1943         v_qs(i, k) = min(0.5, v_qs(i,k))
    1944         zcor = 1./(1.-retv*v_qs(i,k))
    1945         v_qs(i, k) = v_qs(i, k)*zcor
    1946         v_qsd(i, k) = foede(v_t, zdelta, zcvm5, v_qs(i,k), zcor)
     1936        zdelta = max(0., sign(1., rtt - v_t))
     1937        zcvm5 = r5les * rlvtt * (1. - zdelta) + zdelta * r5ies * rlstt
     1938        zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * local_q(i, k))
     1939        v_qs(i, k) = r2es * foeew(v_t, zdelta) / v_p
     1940        v_qs(i, k) = min(0.5, v_qs(i, k))
     1941        zcor = 1. / (1. - retv * v_qs(i, k))
     1942        v_qs(i, k) = v_qs(i, k) * zcor
     1943        v_qsd(i, k) = foede(v_t, zdelta, zcvm5, v_qs(i, k), zcor)
    19471944      ELSE
    19481945        IF (v_t<t_coup) THEN
    1949           v_qs(i, k) = qsats(v_t)/v_p
    1950           v_qsd(i, k) = dqsats(v_t, v_qs(i,k))
     1946          v_qs(i, k) = qsats(v_t) / v_p
     1947          v_qsd(i, k) = dqsats(v_t, v_qs(i, k))
    19511948        ELSE
    1952           v_qs(i, k) = qsatl(v_t)/v_p
    1953           v_qsd(i, k) = dqsatl(v_t, v_qs(i,k))
     1949          v_qs(i, k) = qsatl(v_t) / v_p
     1950          v_qsd(i, k) = dqsatl(v_t, v_qs(i, k))
    19541951        END IF
    19551952      END IF
    19561953    END DO
    19571954    DO k = 2, klev
    1958       zdpm = paprs(i, k-1) - paprs(i, k)
    1959       zdp = paprs(i, k) - paprs(i, k+1)
    1960       gamcpdz(i, k) = ((rd/rcpd/(zdpm+zdp)*(v_cptt(i,k-1)*zdpm+ &
    1961         v_cptt(i,k)*zdp)+rlvtt/(zdpm+zdp)*(v_qs(i,k-1)*zdpm+ &
    1962         v_qs(i,k)*zdp))*(pplay(i,k-1)-pplay(i,k))/paprs(i,k))/(1.0+(v_qsd(i, &
    1963         k-1)*zdpm+v_qsd(i,k)*zdp)/(zdpm+zdp))
     1955      zdpm = paprs(i, k - 1) - paprs(i, k)
     1956      zdp = paprs(i, k) - paprs(i, k + 1)
     1957      gamcpdz(i, k) = ((rd / rcpd / (zdpm + zdp) * (v_cptt(i, k - 1) * zdpm + &
     1958              v_cptt(i, k) * zdp) + rlvtt / (zdpm + zdp) * (v_qs(i, k - 1) * zdpm + &
     1959              v_qs(i, k) * zdp)) * (pplay(i, k - 1) - pplay(i, k)) / paprs(i, k)) / (1.0 + (v_qsd(i, &
     1960              k - 1) * zdpm + v_qsd(i, k) * zdp) / (zdpm + zdp))
    19641961    END DO
    19651962
    … …  
    19671964
    19681965    IF (k1==1) GO TO 841 ! extension echouee
    1969     zflo = v_cptt(i, k1-1) - v_cptt(i, k1) - gamcpdz(i, k1)
    1970     zsat = (local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1)) + &
    1971       (local_q(i,k1)-v_qs(i,k1))*(paprs(i,k1)-paprs(i,k1+1))
     1966    zflo = v_cptt(i, k1 - 1) - v_cptt(i, k1) - gamcpdz(i, k1)
     1967    zsat = (local_q(i, k1 - 1) - v_qs(i, k1 - 1)) * (paprs(i, k1 - 1) - paprs(i, k1)) + &
     1968            (local_q(i, k1) - v_qs(i, k1)) * (paprs(i, k1) - paprs(i, k1 + 1))
    19721969    IF (zflo<=0.0 .OR. zsat<=0.0) GO TO 841 ! extension echouee
    19731970
    1974 840 CONTINUE
     1971    840 CONTINUE
    19751972    k1 = k1 - 1
    19761973    IF (k1==1) GO TO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
    1977     zsat = zsat + (local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1))
    1978     zflo = v_cptt(i, k1-1) - v_cptt(i, k1) - gamcpdz(i, k1)
     1974    zsat = zsat + (local_q(i, k1 - 1) - v_qs(i, k1 - 1)) * (paprs(i, k1 - 1) - paprs(i, k1))
     1975    zflo = v_cptt(i, k1 - 1) - v_cptt(i, k1) - gamcpdz(i, k1)
    19791976    IF (zflo>0.0 .AND. zsat>0.0) THEN
    19801977      GO TO 840
    … …  
    19821979      GO TO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
    19831980    END IF
    1984 841 CONTINUE
     1981    841 CONTINUE
    19851982
    19861983    GO TO 810 ! chercher d'autres blocks en haut
    19871984
    1988 9999 END DO ! boucle sur tous les points
     1985  9999 END DO ! boucle sur tous les points
    19891986  ! -----------------------------------------------------------------------
    19901987
    … …  
    19961993      IF (itest(i)) THEN
    19971994        delta_q(i, k) = local_q(i, k) - q(i, k)
    1998         IF (delta_q(i,k)<0.) rneb(i, k) = 1.0
     1995        IF (delta_q(i, k)<0.) rneb(i, k) = 1.0
    19991996      END IF
    20001997    END DO
    … …  
    20142011    DO i = 1, klon
    20152012      IF (itest(i)) THEN
    2016         zdp = paprs(i, k) - paprs(i, k+1)
    2017         zq1(i) = zq1(i) - delta_q(i, k)*zdp
    2018         zq2(i) = zq2(i) - min(0.0, delta_q(i,k))*zdp
     2013        zdp = paprs(i, k) - paprs(i, k + 1)
     2014        zq1(i) = zq1(i) - delta_q(i, k) * zdp
     2015        zq2(i) = zq2(i) - min(0.0, delta_q(i, k)) * zdp
    20192016      END IF
    20202017    END DO
    … …  
    20232020    DO i = 1, klon
    20242021      IF (itest(i)) THEN
    2025         IF (zq2(i)/=0.0) d_ql(i, k) = -min(0.0, delta_q(i,k))*zq1(i)/zq2(i)
     2022        IF (zq2(i)/=0.0) d_ql(i, k) = -min(0.0, delta_q(i, k)) * zq1(i) / zq2(i)
    20262023      END IF
    20272024    END DO
    … …  
    20302027  DO k = 1, klev
    20312028    DO i = 1, klon
    2032       local_q(i, k) = max(local_q(i,k), seuil_vap)
     2029      local_q(i, k) = max(local_q(i, k), seuil_vap)
    20332030    END DO
    20342031  END DO
    … …  
    20412038  END DO
    20422039
    2043 
    20442040END SUBROUTINE fiajh
    20452041SUBROUTINE fiajc(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, d_ql, rneb, &
    2046     rain, snow, ibas, itop)
     2042        rain, snow, ibas, itop)
    20472043  USE dimphy
     2044  USE lmdz_YOETHF
     2045  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     2046
    20482047  IMPLICIT NONE
    20492048
    … …  
    20532052
    20542053  INTEGER plb ! niveau de depart pour la convection
    2055   PARAMETER (plb=4)
     2054  PARAMETER (plb = 4)
    20562055
    20572056  ! Mystere: cette option n'est pas innocente pour les resultats !
    20582057  ! Qui peut resoudre ce mystere ? (Z.X.Li mars 1995)
    20592058  LOGICAL vector ! calcul vectorise
    2060   PARAMETER (vector=.FALSE.)
     2059  PARAMETER (vector = .FALSE.)
    20612060
    20622061  REAL t_coup
    2063   PARAMETER (t_coup=234.0)
     2062  PARAMETER (t_coup = 234.0)
    20642063
    20652064  ! Arguments:
    … …  
    20672066  REAL q(klon, klev) ! humidite specifique (kg/kg)
    20682067  REAL t(klon, klev) ! temperature (K)
    2069   REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
     2068  REAL paprs(klon, klev + 1) ! pression a inter-couche (Pa)
    20702069  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
    20712070  REAL dtime ! intervalle du temps (s)
    … …  
    20882087  REAL zdelta, zcor, zcvm5
    20892088
    2090   include "YOETHF.h"
    2091   include "FCTTRE.h"
    2092 
    20932089  ! Initialiser les sorties:
    20942090
    … …  
    21142110      ztt = t(i, k)
    21152111      IF (thermcep) THEN
    2116         zdelta = max(0., sign(1.,rtt-ztt))
    2117         zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
    2118         zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k))
    2119         zqs(i, k) = r2es*foeew(ztt, zdelta)/pplay(i, k)
    2120         zqs(i, k) = min(0.5, zqs(i,k))
    2121         zcor = 1./(1.-retv*zqs(i,k))
    2122         zqs(i, k) = zqs(i, k)*zcor
    2123         zdqs(i, k) = foede(ztt, zdelta, zcvm5, zqs(i,k), zcor)
     2112        zdelta = max(0., sign(1., rtt - ztt))
     2113        zcvm5 = r5les * rlvtt * (1. - zdelta) + zdelta * r5ies * rlstt
     2114        zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * q(i, k))
     2115        zqs(i, k) = r2es * foeew(ztt, zdelta) / pplay(i, k)
     2116        zqs(i, k) = min(0.5, zqs(i, k))
     2117        zcor = 1. / (1. - retv * zqs(i, k))
     2118        zqs(i, k) = zqs(i, k) * zcor
     2119        zdqs(i, k) = foede(ztt, zdelta, zcvm5, zqs(i, k), zcor)
    21242120      ELSE
    21252121        IF (ztt<t_coup) THEN
    2126           zqs(i, k) = qsats(ztt)/pplay(i, k)
    2127           zdqs(i, k) = dqsats(ztt, zqs(i,k))
     2122          zqs(i, k) = qsats(ztt) / pplay(i, k)
     2123          zdqs(i, k) = dqsats(ztt, zqs(i, k))
    21282124        ELSE
    2129           zqs(i, k) = qsatl(ztt)/pplay(i, k)
    2130           zdqs(i, k) = dqsatl(ztt, zqs(i,k))
     2125          zqs(i, k) = qsatl(ztt) / pplay(i, k)
     2126          zdqs(i, k) = dqsatl(ztt, zqs(i, k))
    21312127        END IF
    21322128      END IF
    … …  
    21382134  DO i = 1, klon
    21392135    k = plb
    2140     zdeh(i, k) = rcpd*(t(i,k-1)-t(i,k)) - rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k &
    2141       )*(pplay(i,k-1)-pplay(i,k)) + rlvtt*(zqs(i,k-1)-zqs(i,k))
    2142     zdeh(i, k) = zdeh(i, k)*0.5 ! on prend la moitie
     2136    zdeh(i, k) = rcpd * (t(i, k - 1) - t(i, k)) - rd * 0.5 * (t(i, k - 1) + t(i, k)) / paprs(i, k &
     2137            ) * (pplay(i, k - 1) - pplay(i, k)) + rlvtt * (zqs(i, k - 1) - zqs(i, k))
     2138    zdeh(i, k) = zdeh(i, k) * 0.5 ! on prend la moitie
    21432139  END DO
    21442140  DO k = plb + 1, klev
    21452141    DO i = 1, klon
    2146       zdeh(i, k) = zdeh(i, k-1) + rcpd*(t(i,k-1)-t(i,k)) - &
    2147         rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1)-pplay(i,k)) + &
    2148         rlvtt*(zqs(i,k-1)-zqs(i,k))
     2142      zdeh(i, k) = zdeh(i, k - 1) + rcpd * (t(i, k - 1) - t(i, k)) - &
     2143              rd * 0.5 * (t(i, k - 1) + t(i, k)) / paprs(i, k) * (pplay(i, k - 1) - pplay(i, k)) + &
     2144              rlvtt * (zqs(i, k - 1) - zqs(i, k))
    21492145    END DO
    21502146  END DO
    … …  
    21642160      IF (nuage(i)) THEN
    21652161        kh(i) = k
    2166         zconv(i) = zconv(i) + conv_q(i, k)*dtime*(paprs(i,k)-paprs(i,k+1))
    2167         zvirt(i) = zvirt(i) + (zdeh(i,k)/rlvtt+zqs(i,k)-q(i,k))*(paprs(i,k)- &
    2168           paprs(i,k+1))
     2162        zconv(i) = zconv(i) + conv_q(i, k) * dtime * (paprs(i, k) - paprs(i, k + 1))
     2163        zvirt(i) = zvirt(i) + (zdeh(i, k) / rlvtt + zqs(i, k) - q(i, k)) * (paprs(i, k) - &
     2164                paprs(i, k + 1))
    21692165      END IF
    21702166    END DO
    … …  
    21722168
    21732169  IF (vector) THEN
    2174 
    21752170
    21762171    DO k = plb, klev
    … …  
    21782173        IF (k<=kh(i) .AND. kh(i)>plb .AND. zconv(i)>0.0) THEN
    21792174          test(i, k) = .TRUE.
    2180           zfrac(i) = max(0.0, min(zconv(i)/zvirt(i),1.0))
     2175          zfrac(i) = max(0.0, min(zconv(i) / zvirt(i), 1.0))
    21812176        ELSE
    21822177          test(i, k) = .FALSE.
    … …  
    21872182    DO k = plb, klev
    21882183      DO i = 1, klon
    2189         IF (test(i,k)) THEN
    2190           zvar = zdeh(i, k)/(1.0+zdqs(i,k))
    2191           d_q(i, k) = (zvar*zdqs(i,k)/rlvtt+zqs(i,k)-q(i,k))*zfrac(i) - &
    2192             conv_q(i, k)*dtime
    2193           d_t(i, k) = zvar*zfrac(i)/rcpd
     2184        IF (test(i, k)) THEN
     2185          zvar = zdeh(i, k) / (1.0 + zdqs(i, k))
     2186          d_q(i, k) = (zvar * zdqs(i, k) / rlvtt + zqs(i, k) - q(i, k)) * zfrac(i) - &
     2187                  conv_q(i, k) * dtime
     2188          d_t(i, k) = zvar * zfrac(i) / rcpd
    21942189        END IF
    21952190      END DO
    … …  
    22022197    DO k = plb, klev
    22032198      DO i = 1, klon
    2204         IF (test(i,k)) THEN
    2205           IF (d_q(i,k)<0.0) rneb(i, k) = zfrac(i)
    2206           zq1(i) = zq1(i) - d_q(i, k)*(paprs(i,k)-paprs(i,k+1))
    2207           zq2(i) = zq2(i) - min(0.0, d_q(i,k))*(paprs(i,k)-paprs(i,k+1))
     2199        IF (test(i, k)) THEN
     2200          IF (d_q(i, k)<0.0) rneb(i, k) = zfrac(i)
     2201          zq1(i) = zq1(i) - d_q(i, k) * (paprs(i, k) - paprs(i, k + 1))
     2202          zq2(i) = zq2(i) - min(0.0, d_q(i, k)) * (paprs(i, k) - paprs(i, k + 1))
    22082203        END IF
    22092204      END DO
    … …  
    22122207    DO k = plb, klev
    22132208      DO i = 1, klon
    2214         IF (test(i,k)) THEN
    2215           IF (zq2(i)/=0.) d_ql(i, k) = -min(0.0, d_q(i,k))*zq1(i)/zq2(i)
     2209        IF (test(i, k)) THEN
     2210          IF (zq2(i)/=0.) d_ql(i, k) = -min(0.0, d_q(i, k)) * zq1(i) / zq2(i)
    22162211        END IF
    22172212      END DO
    … …  
    22242219        ! cc         IF (kh(i).LE.plb) GOTO 999 ! il n'y a pas d'instabilite
    22252220        ! cc         IF (zconv(i).LE.0.0) GOTO 999 ! convergence insuffisante
    2226         zfrac(i) = max(0.0, min(zconv(i)/zvirt(i),1.0))
     2221        zfrac(i) = max(0.0, min(zconv(i) / zvirt(i), 1.0))
    22272222        DO k = plb, kh(i)
    2228           zvar = zdeh(i, k)/(1.0+zdqs(i,k))
    2229           d_q(i, k) = (zvar*zdqs(i,k)/rlvtt+zqs(i,k)-q(i,k))*zfrac(i) - &
    2230             conv_q(i, k)*dtime
    2231           d_t(i, k) = zvar*zfrac(i)/rcpd
     2223          zvar = zdeh(i, k) / (1.0 + zdqs(i, k))
     2224          d_q(i, k) = (zvar * zdqs(i, k) / rlvtt + zqs(i, k) - q(i, k)) * zfrac(i) - &
     2225                  conv_q(i, k) * dtime
     2226          d_t(i, k) = zvar * zfrac(i) / rcpd
    22322227        END DO
    22332228
    … …  
    22352230        zq2(i) = 0.0
    22362231        DO k = plb, kh(i)
    2237           IF (d_q(i,k)<0.0) rneb(i, k) = zfrac(i)
    2238           zq1(i) = zq1(i) - d_q(i, k)*(paprs(i,k)-paprs(i,k+1))
    2239           zq2(i) = zq2(i) - min(0.0, d_q(i,k))*(paprs(i,k)-paprs(i,k+1))
     2232          IF (d_q(i, k)<0.0) rneb(i, k) = zfrac(i)
     2233          zq1(i) = zq1(i) - d_q(i, k) * (paprs(i, k) - paprs(i, k + 1))
     2234          zq2(i) = zq2(i) - min(0.0, d_q(i, k)) * (paprs(i, k) - paprs(i, k + 1))
    22402235        END DO
    22412236        DO k = plb, kh(i)
    2242           IF (zq2(i)/=0.) d_ql(i, k) = -min(0.0, d_q(i,k))*zq1(i)/zq2(i)
     2237          IF (zq2(i)/=0.) d_ql(i, k) = -min(0.0, d_q(i, k)) * zq1(i) / zq2(i)
    22432238        END DO
    22442239      END IF
    … …  
    22472242  END IF ! fin de teste sur vector
    22482243
    2249 
    22502244END SUBROUTINE fiajc

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

    r5141 r5143  
    11SUBROUTINE cv3_enthalpmix(len, nd, iflag, plim1, plim2, p, ph, &
    2                        t, q, u, v, w, &
    3                        wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl)
     2        t, q, u, v, w, wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl)
    43  ! **************************************************************
    54  ! *
    … …  
    109  ! modified by :  Filiberti M-A 06/2005 vectorisation          *
    1110  ! **************************************************************
    12 USE lmdz_cvthermo
     11  USE lmdz_cvthermo
     12  USE lmdz_YOETHF
     13  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     14
    1315  IMPLICIT NONE
    1416  ! ==============================================================
    … …  
    2224  ! ===============================================================
    2325
    24   include "YOETHF.h"
    2526  include "YOMCST.h"
    26   include "FCTTRE.h"
    27 !inputs:
    28   INTEGER, INTENT (IN)                      :: nd, len
    29   INTEGER, DIMENSION (len), INTENT (IN)     :: nk
    30   REAL, DIMENSION (len), INTENT (IN)        :: plim1, plim2
    31   REAL, DIMENSION (len,nd), INTENT (IN)     :: t, q
    32   REAL, DIMENSION (len,nd), INTENT (IN)     :: u, v
    33   REAL, DIMENSION (nd), INTENT (IN)         :: w
    34   REAL, DIMENSION (len,nd), INTENT (IN)     :: p
    35   REAL, DIMENSION (len,nd+1), INTENT (IN)   :: ph
    36 !input/output:
    37   INTEGER, DIMENSION (len), INTENT (INOUT)  ::  iflag
    38 !outputs:
    39   REAL, DIMENSION (len), INTENT (OUT)       :: tmix, thmix, qmix
    40   REAL, DIMENSION (len), INTENT (OUT)       :: umix, vmix
    41   REAL, DIMENSION (len), INTENT (OUT)       :: qsmix
    42   REAL, DIMENSION (len), INTENT (OUT)       :: plcl
    43   REAL, DIMENSION (len,nd), INTENT (OUT)    :: wi
    44 !internal variables :
     27  !inputs:
     28  INTEGER, INTENT (IN) :: nd, len
     29  INTEGER, DIMENSION (len), INTENT (IN) :: nk
     30  REAL, DIMENSION (len), INTENT (IN) :: plim1, plim2
     31  REAL, DIMENSION (len, nd), INTENT (IN) :: t, q
     32  REAL, DIMENSION (len, nd), INTENT (IN) :: u, v
     33  REAL, DIMENSION (nd), INTENT (IN) :: w
     34  REAL, DIMENSION (len, nd), INTENT (IN) :: p
     35  REAL, DIMENSION (len, nd + 1), INTENT (IN) :: ph
     36  !input/output:
     37  INTEGER, DIMENSION (len), INTENT (INOUT) :: iflag
     38  !outputs:
     39  REAL, DIMENSION (len), INTENT (OUT) :: tmix, thmix, qmix
     40  REAL, DIMENSION (len), INTENT (OUT) :: umix, vmix
     41  REAL, DIMENSION (len), INTENT (OUT) :: qsmix
     42  REAL, DIMENSION (len), INTENT (OUT) :: plcl
     43  REAL, DIMENSION (len, nd), INTENT (OUT) :: wi
     44  !internal variables :
    4545  INTEGER i, j
    4646  INTEGER niflag7
    47   INTEGER, DIMENSION(len)                   :: j1, j2
    48   REAL                                      :: a, b
    49   REAL                                      :: cpn
    50   REAL                                      :: x, y, p0, p0m1, zdelta, zcor
    51   REAL, SAVE                                :: dpmin=1.
    52 !$OMP THREADPRIVATE(dpmin)
    53   REAL, DIMENSION(len)                      :: plim2p  ! = min(plim2(:),plim1(:)-dpmin)
    54   REAL, DIMENSION(len)                      :: akm     ! mixture enthalpy
    55   REAL, DIMENSION(len)                      :: dpw, coef
    56   REAL, DIMENSION(len)                      :: rdcp, a2, b2, pnk
    57   REAL, DIMENSION(len)                      :: rh, chi
    58   REAL, DIMENSION(len)                      :: eqwght
    59   REAL, DIMENSION(len,nd)                  :: p1, p2
    60 
    61 
    62 !!  print *,' ->cv3_vertmix, plim1,plim2 ', plim1,plim2   !jyg
    63   plim2p(:) = min(plim2(:),plim1(:)-dpmin)
    64   j1(:)=nd
     47  INTEGER, DIMENSION(len) :: j1, j2
     48  REAL :: a, b
     49  REAL :: cpn
     50  REAL :: x, y, p0, p0m1, zdelta, zcor
     51  REAL, SAVE :: dpmin = 1.
     52  !$OMP THREADPRIVATE(dpmin)
     53  REAL, DIMENSION(len) :: plim2p  ! = min(plim2(:),plim1(:)-dpmin)
     54  REAL, DIMENSION(len) :: akm     ! mixture enthalpy
     55  REAL, DIMENSION(len) :: dpw, coef
     56  REAL, DIMENSION(len) :: rdcp, a2, b2, pnk
     57  REAL, DIMENSION(len) :: rh, chi
     58  REAL, DIMENSION(len) :: eqwght
     59  REAL, DIMENSION(len, nd) :: p1, p2
     60
     61
     62  !!  print *,' ->cv3_vertmix, plim1,plim2 ', plim1,plim2   !jyg
     63  plim2p(:) = min(plim2(:), plim1(:) - dpmin)
     64  j1(:) = nd
    6565  j2(:) = 0
    6666  DO j = 1, nd
    6767    DO i = 1, len
    68       IF (plim1(i)<=ph(i,j)) j1(i) = j
    69 !!!      IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)<ph(i,j)) j2(i) = j
    70       IF (plim2p(i)< ph(i,j)) j2(i) = j
     68      IF (plim1(i)<=ph(i, j)) j1(i) = j
     69      !!!      IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)<ph(i,j)) j2(i) = j
     70      IF (plim2p(i)< ph(i, j)) j2(i) = j
    7171    END DO
    7272  END DO
    … …  
    9090
    9191  p0 = 1000.
    92   p0m1 = 1./p0
     92  p0m1 = 1. / p0
    9393
    9494  DO i = 1, len
    … …  
    9797      eqwght(i) = 1.
    9898    ELSE
    99       coef(i) = 1./(plim1(i)-plim2p(i))
     99      coef(i) = 1. / (plim1(i) - plim2p(i))
    100100    ENDIF
    101101  END DO
    102102
    103 !!  print *,'cv3_vertmix, j1,j2,coef ', j1,j2,coef  !jyg
     103  !!  print *,'cv3_vertmix, j1,j2,coef ', j1,j2,coef  !jyg
    104104
    105105  DO j = 1, nd
    106106    DO i = 1, len
    107107      IF (j>=j1(i) .AND. j<=j2(i)) THEN
    108         p1(i, j) = min(ph(i,j), plim1(i))
    109         p2(i, j) = max(ph(i,j+1), plim2p(i))
     108        p1(i, j) = min(ph(i, j), plim1(i))
     109        p2(i, j) = max(ph(i, j + 1), plim2p(i))
    110110        ! CRtest:couplage thermiques: deja normalise
    111111        ! wi(i,j) = w(j)
    112112        ! PRINT*,'wi',wi(i,j)
    113         wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)+eqwght(i)
     113        wi(i, j) = w(j) * (p1(i, j) - p2(i, j)) * coef(i) + eqwght(i)
    114114        dpw(i) = dpw(i) + wi(i, j)
    115115
    116 !!  print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw  !jyg
     116        !!  print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw  !jyg
    117117
    118118      END IF
    … …  
    127127    DO i = 1, len
    128128      IF (j>=j1(i) .AND. j<=j2(i)) THEN
    129         wi(i, j) = wi(i, j)/dpw(i)
    130         akm(i) = akm(i) + (cpd*(1.-q(i,j))+q(i,j)*cpv)*t(i, j)*wi(i, j)
    131         qmix(i) = qmix(i) + q(i, j)*wi(i, j)
    132         umix(i) = umix(i) + u(i, j)*wi(i, j)
    133         vmix(i) = vmix(i) + v(i, j)*wi(i, j)
     129        wi(i, j) = wi(i, j) / dpw(i)
     130        akm(i) = akm(i) + (cpd * (1. - q(i, j)) + q(i, j) * cpv) * t(i, j) * wi(i, j)
     131        qmix(i) = qmix(i) + q(i, j) * wi(i, j)
     132        umix(i) = umix(i) + u(i, j) * wi(i, j)
     133        vmix(i) = vmix(i) + v(i, j) * wi(i, j)
    134134      END IF
    135135    END DO
    … …  
    137137
    138138  DO i = 1, len
    139     rdcp(i) = (rrd*(1.-qmix(i))+qmix(i)*rrv)/(cpd*(1.-qmix(i))+qmix(i)*cpv)
    140   END DO
    141 
    142 
    143 !!  print *,'cv3_vertmix, rdcp ', rdcp  !jyg
    144 
    145 
     139    rdcp(i) = (rrd * (1. - qmix(i)) + qmix(i) * rrv) / (cpd * (1. - qmix(i)) + qmix(i) * cpv)
     140  END DO
     141
     142
     143  !!  print *,'cv3_vertmix, rdcp ', rdcp  !jyg
    146144
    147145  DO j = 1, nd
    … …  
    149147      IF (j>=j1(i) .AND. j<=j2(i)) THEN
    150148        ! c            x=(.5*(p1(i,j)+p2(i,j))*p0m1)**rdcp(i)
    151         y = (.5*(p1(i,j)+p2(i,j))/pnk(i))**rdcp(i)
     149        y = (.5 * (p1(i, j) + p2(i, j)) / pnk(i))**rdcp(i)
    152150        ! c            a2(i)=a2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*x*wi(i,j)
    153         b2(i) = b2(i) + (cpd*(1.-qmix(i))+qmix(i)*cpv)*y*wi(i, j)
     151        b2(i) = b2(i) + (cpd * (1. - qmix(i)) + qmix(i) * cpv) * y * wi(i, j)
    154152      END IF
    155153    END DO
    … …  
    157155
    158156  DO i = 1, len
    159     tmix(i) = akm(i)/b2(i)
    160     thmix(i) = tmix(i)*(p0/pnk(i))**rdcp(i)
     157    tmix(i) = akm(i) / b2(i)
     158    thmix(i) = tmix(i) * (p0 / pnk(i))**rdcp(i)
    161159    ! PRINT*,'thmix akm',akm(i),b2(i)
    162160    ! PRINT*,'thmix t',tmix(i),p0
    … …  
    165163    ! c         thmix(i) = akm(i)/a2(i)
    166164    ! c         tmix(i)= thmix(i)*(pnk(i)*p0m1)**rdcp(i)
    167     zdelta = max(0., sign(1.,rtt-tmix(i)))
    168     qsmix(i) = r2es*foeew(tmix(i), zdelta)/(pnk(i)*100.)
     165    zdelta = max(0., sign(1., rtt - tmix(i)))
     166    qsmix(i) = r2es * foeew(tmix(i), zdelta) / (pnk(i) * 100.)
    169167    qsmix(i) = min(0.5, qsmix(i))
    170     zcor = 1./(1.-retv*qsmix(i))
    171     qsmix(i) = qsmix(i)*zcor
     168    zcor = 1. / (1. - retv * qsmix(i))
     169    qsmix(i) = qsmix(i) * zcor
    172170  END DO
    173171
    … …  
    180178  b = 122.0 ! convect3
    181179
    182 
    183180  niflag7 = 0
    184181  DO i = 1, len
    … …  
    186183    IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
    187184
    188       rh(i) = qmix(i)/qsmix(i)
    189       chi(i) = tmix(i)/(a-b*rh(i)-tmix(i)) ! convect3
     185      rh(i) = qmix(i) / qsmix(i)
     186      chi(i) = tmix(i) / (a - b * rh(i) - tmix(i)) ! convect3
    190187      ! ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET
    191188      ! MASQUE UN PB POTENTIEL
    192189      chi(i) = max(chi(i), 0.)
    193190      rh(i) = max(rh(i), 0.)
    194       plcl(i) = pnk(i)*(rh(i)**chi(i))
     191      plcl(i) = pnk(i) * (rh(i)**chi(i))
    195192      IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) &
    196           iflag(i) = 8
     193              iflag(i) = 8
    197194
    198195    ELSE
    … …  
    207204  END DO
    208205
    209 !!  print *,' cv3_vertmix->'  !jyg
    210 
    211 
     206  !!  print *,' cv3_vertmix->'  !jyg
    212207
    213208END SUBROUTINE cv3_enthalpmix

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

    r5141 r5143  
    1212  ! ****************************************************************
    1313USE lmdz_cvthermo
     14USE lmdz_YOETHF
     15USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     16
    1417  IMPLICIT NONE
    1518  ! ==============================================================
    … …  
    2326  ! ===============================================================
    2427
    25   include "YOETHF.h"
    2628  include "YOMCST.h"
    27   include "FCTTRE.h"
    2829!inputs:
    2930  INTEGER, INTENT (IN)                      :: nd, len

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

    r5105 r5143  
    4848
    4949  USE dimphy
     50  USE lmdz_YOETHF
     51
    5052  IMPLICIT NONE
    5153
    5254  include "YOMCST.h"
    53   include "YOETHF.h"
    5455
    5556  ! Input variables
    … …  
    205206
    206207  USE dimphy
     208  USE lmdz_YOETHF
     209
    207210  IMPLICIT NONE
    208211
    209212  include "YOMCST.h"
    210   include "YOETHF.h"
    211213
    212214  ! Input variables

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

    r5142 r5143  
    13181318    ! ========================================================
    13191319    USE dimphy
     1320    USE lmdz_YOETHF
     1321    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    13201322
    13211323    IMPLICIT NONE
    … …  
    13391341
    13401342    include "YOMCST.h"
    1341     include "YOETHF.h"
    1342 
    1343     !  ----------------------------------------
    1344     !  Statement functions
    1345     include "FCTTRE.h"
    1346     !  ----------------------------------------
    13471343
    13481344    DO k = 1, klev
    … …  
    13981394    ! ========================================================
    13991395    USE dimphy
     1396    USE lmdz_YOETHF
     1397    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    14001398
    14011399    IMPLICIT NONE
    … …  
    14301428
    14311429    include "YOMCST.h"
    1432     include "YOETHF.h"
    1433 
    1434     !  ----------------------------------------
    1435     !  Statement functions
    1436     include "FCTTRE.h"
    1437     !  ----------------------------------------
    14381430
    14391431    print *, 'dtime, tau ', dtime, tau

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

    r5139 r5143  
    3232USE lmdz_clesphys
    3333USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree
     34USE lmdz_YOETHF
    3435
    3536IMPLICIT NONE
    3637INCLUDE "YOMCST.h"
    37 INCLUDE "YOETHF.h"
    3838
    3939! Arguments

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

    r5087 r5143  
    11SUBROUTINE evappot(klon,nbsrf,ftsol,pplay,cdragh,  &
    22      t_seri,q_seri,u_seri,v_seri,evap_pot)
     3USE lmdz_YOETHF
     4USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    35
    46IMPLICIT NONE
    57
    68INCLUDE "YOMCST.h"
    7 INCLUDE "YOETHF.h"
    8 INCLUDE "FCTTRE.h"
    99
    1010

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

    r5112 r5143  
    1111  USE dimphy
    1212  USE lmdz_print_control, ONLY: lunout
     13  USE lmdz_YOETHF
     14  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     15
    1316  IMPLICIT NONE
    1417  ! ======================================================================
    … …  
    122125  REAL fallv ! vitesse de chute pour crystaux de glace
    123126  REAL zzz
    124   include "YOETHF.h"
    125   include "FCTTRE.h"
    126127  fallv(zzz) = 3.29/2.0*((zzz)**0.16)
    127128  ! cc      fallv (zzz) = 3.29/3.0 * ((zzz)**0.16)

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

    r5137 r5143  
    2424    USE lmdz_abort_physic, ONLY: abort_physic
    2525    USE lmdz_clesphys
     26    USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     27          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
    2628
    2729    CHARACTER (LEN = 20) :: modname = 'flott_gwd_rando'
    … …  
    3335    ! include "dimphy.h"
    3436    ! END OF DIFFERENCE ONLINE-OFFLINE
    35     include "YOEGWD.h"
    3637
    3738    ! 0. DECLARATIONS:

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

    r5137 r5143  
    241241    USE indice_sol_mod
    242242  USE lmdz_clesphys
     243  USE lmdz_YOETHF
    243244#ifdef ISO
    244245    USE infotrac_phy, ONLY: niso
    … …  
    248249#endif
    249250#endif
     251  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    250252       
    251253! Routine de traitement de la fonte de la neige dans le cas du traitement
    … …  
    267269!   evap
    268270
    269   INCLUDE "YOETHF.h"
    270271  INCLUDE "YOMCST.h"
    271   INCLUDE "FCTTRE.h"
    272272
    273273! Input variables

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

    r5142 r5143  
    1212!    USE control, ONLY: nvm
    1313!    USE indice_sol_mod, ONLY: nvm_orch
     14    USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     15          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
    1416
    1517    IMPLICIT NONE
    … …  
    1719
    1820    include "YOMCST.h"
    19     include "YOEGWD.h"
    2021
    2122    ! 0. DECLARATIONS:

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

    r5117 r5143  
    1 
    21! $Header$
    32
    43SUBROUTINE hbtm2l(knon, paprs, pplay, t2m, t10m, q2m, q10m, ustar, flux_t, flux_q, u, v, t, q, pblh, therm, plcl, cape, &
    5     cin, eauliq, ctei, d_qt, d_thv, dlt_2, xhis, posint, omega, diagok)
     4        cin, eauliq, ctei, d_qt, d_thv, dlt_2, xhis, posint, omega, diagok)
    65  USE dimphy
     6  USE lmdz_YOETHF
     7  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     8
    79  IMPLICIT NONE
    810
    … …  
    3840  REAL q2m(klon), q10m(klon) ! q a 2 et 10m
    3941  REAL ustar(klon)
    40   REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
     42  REAL paprs(klon, klev + 1) ! pression a inter-couche (Pa)
    4143  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
    4244  REAL flux_t(klon, klev), flux_q(klon, klev) ! Flux
    … …  
    4850  INTEGER isommet
    4951  REAL vk
    50   PARAMETER (vk=0.35) ! Von Karman => passer a .41 ! cf U.Olgstrom
     52  PARAMETER (vk = 0.35) ! Von Karman => passer a .41 ! cf U.Olgstrom
    5153  REAL ricr
    52   PARAMETER (ricr=0.4)
     54  PARAMETER (ricr = 0.4)
    5355  REAL fak
    54   PARAMETER (fak=8.5) ! b calcul du Prandtl et de dTetas
     56  PARAMETER (fak = 8.5) ! b calcul du Prandtl et de dTetas
    5557  REAL fakn
    56   PARAMETER (fakn=7.2) ! a
     58  PARAMETER (fakn = 7.2) ! a
    5759  REAL onet
    58   PARAMETER (onet=1.0/3.0)
     60  PARAMETER (onet = 1.0 / 3.0)
    5961  REAL betam
    60   PARAMETER (betam=15.0) ! pour Phim / h dans la S.L stable
     62  PARAMETER (betam = 15.0) ! pour Phim / h dans la S.L stable
    6163  REAL betah
    62   PARAMETER (betah=15.0)
     64  PARAMETER (betah = 15.0)
    6365  REAL betas
    64   PARAMETER (betas=5.0) ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1
     66  PARAMETER (betas = 5.0) ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1
    6567  REAL sffrac
    66   PARAMETER (sffrac=0.1) ! S.L. = z/h < .1
     68  PARAMETER (sffrac = 0.1) ! S.L. = z/h < .1
    6769  REAL binm
    68   PARAMETER (binm=betam*sffrac)
     70  PARAMETER (binm = betam * sffrac)
    6971  REAL binh
    70   PARAMETER (binh=betah*sffrac)
     72  PARAMETER (binh = betah * sffrac)
    7173
    7274  REAL q_star, t_star
    7375  REAL b1, b2, b212, b2sr ! Lambert correlations T' q' avec T* q*
    74   PARAMETER (b1=70., b2=20.) ! b1 entre 70 et 100
     76  PARAMETER (b1 = 70., b2 = 20.) ! b1 entre 70 et 100
    7577
    7678  REAL z(klon, klev)
    7779  ! AM
    7880  REAL zref, dt0
    79   PARAMETER (zref=2.) ! Niveau de ref a 2m
    80   PARAMETER (dt0=0.1) ! convergence do while
     81  PARAMETER (zref = 2.) ! Niveau de ref a 2m
     82  PARAMETER (dt0 = 0.1) ! convergence do while
    8183
    8284  INTEGER i, k, j
    … …  
    130132  REAL missing_val
    131133
    132   include "YOETHF.h"
    133   include "FCTTRE.h"
    134 
    135134  ! c      missing_val=nf90_fill_real (avec include netcdf)
    136135  missing_val = 0.
    … …  
    138137  ! initialisations (Anne)
    139138  isommet = klev
    140   b212 = sqrt(b1*b2)
     139  b212 = sqrt(b1 * b2)
    141140  b2sr = sqrt(b2)
    142141
    143142  ! Initialisation thermo
    144   rlvcp = rlvtt/rcpd
    145   reps = rd/rv
     143  rlvcp = rlvtt / rcpd
     144  reps = rd / rv
    146145  ! raz
    147146  q_star = 0.
    … …  
    164163  ! Calculer les hauteurs de chaque couche
    165164  DO i = 1, knon
    166     z(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i,1)))*(paprs(i,1)-pplay(i,1))/rg
    167     s(i, 1) = (pplay(i,1)/paprs(i,1))**rkappa
     165    z(i, 1) = rd * t(i, 1) / (0.5 * (paprs(i, 1) + pplay(i, 1))) * (paprs(i, 1) - pplay(i, 1)) / rg
     166    s(i, 1) = (pplay(i, 1) / paprs(i, 1))**rkappa
    168167  END DO
    169168  ! s(k) = [pplay(k)/ps]^kappa
    … …  
    181180  DO k = 2, klev
    182181    DO i = 1, knon
    183       z(i, k) = z(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1)-pplay(i,k))/rg
    184       s(i, k) = (pplay(i,k)/paprs(i,1))**rkappa
     182      z(i, k) = z(i, k - 1) + rd * 0.5 * (t(i, k - 1) + t(i, k)) / paprs(i, k) * (pplay(i, k - 1) - pplay(i, k)) / rg
     183      s(i, k) = (pplay(i, k) / paprs(i, 1))**rkappa
    185184    END DO
    186185  END DO
    … …  
    212211    ! AM calcul de Ro = paprs(i,1)/Rd zxt
    213212    ! AM convention >0 vers le bas ds lmdz
    214     khfs(i) = -flux_t(i, 1)*zxt*rd/(rcpd*paprs(i,1))
    215     kqfs(i) = -flux_q(i, 1)*zxt*rd/(paprs(i,1))
     213    khfs(i) = -flux_t(i, 1) * zxt * rd / (rcpd * paprs(i, 1))
     214    kqfs(i) = -flux_q(i, 1) * zxt * rd / (paprs(i, 1))
    216215    ! AM   verifier que khfs et kqfs sont bien de la forme w'l'
    217     heatv(i) = khfs(i) + retv*zxt*kqfs(i)
     216    heatv(i) = khfs(i) + retv * zxt * kqfs(i)
    218217    ! a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
    219218    ! AM ustar est en entree (calcul dans stdlevvar avec t2m q2m)
    … …  
    233232    IF (heatv(i)>0.0001) THEN
    234233      ! Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
    235       obklen(i) = -t(i, 1)*ustar(i)**3/(rg*vk*heatv(i))
     234      obklen(i) = -t(i, 1) * ustar(i)**3 / (rg * vk * heatv(i))
    236235    ELSE
    237236      ! set pblh to the friction high (cf + bas)
    238       pblh(i) = 700.0*ustar(i)
     237      pblh(i) = 700.0 * ustar(i)
    239238      check(i) = .FALSE.
    240239    END IF
    … …  
    255254        zdu2 = max(zdu2, 1.0E-20)
    256255        ! Theta_v environnement
    257         zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
    258         zthvu = th_th(i)*(1.+retv*qt_th(i))
     256        zthvd = t(i, k) / s(i, k) * (1. + retv * q(i, k))
     257        zthvu = th_th(i) * (1. + retv * qt_th(i))
    259258        ! Le Ri bulk par Theta_v
    260         rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5*(zthvd+zthvu))
    261 
    262         IF (rhino(i,k)>=ricr) THEN
    263           pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
     259        rhino(i, k) = (z(i, k) - zref) * rg * (zthvd - zthvu) / (zdu2 * 0.5 * (zthvd + zthvu))
     260
     261        IF (rhino(i, k)>=ricr) THEN
     262          pblh(i) = z(i, k - 1) + (z(i, k - 1) - z(i, k)) * (ricr - rhino(i, k - 1)) / (rhino(i, k - 1) - rhino(i, k))
    264263          ! test04 (la pblh est encore ici sous-estime'e)
    265264          pblh(i) = pblh(i) + 100.
    … …  
    298297  DO i = 1, knon
    299298    IF (check(i)) THEN
    300       phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
     299      phiminv(i) = (1. - binm * pblh(i) / obklen(i))**onet
    301300      ! ***************************************************
    302301      ! Wm ? et W* ? c'est la formule pour z/h < .1
    … …  
    317316      ! END IF
    318317      ! ***************************************************
    319       wm(i) = ustar(i)*phiminv(i)
     318      wm(i) = ustar(i) * phiminv(i)
    320319      ! ======================================================================
    321320      ! valeurs de Dominique Lambert de la campagne SEMAPHORE :
    … …  
    343342      ! HBTM        therm(i) = heatv(i)*fak/wm(i)
    344343      ! forme Mathieu :
    345       q_star = max(0., kqfs(i)/wm(i))
    346       t_star = max(0., khfs(i)/wm(i))
     344      q_star = max(0., kqfs(i) / wm(i))
     345      t_star = max(0., khfs(i) / wm(i))
    347346      ! Al1 Houston, we have a problem : il arrive en effet que heatv soit
    348347      ! positif (=thermique instable) mais pas t_star : avec evaporation
    349348      ! importante, il se peut qu'on refroidisse la 2m Que faire alors ?
    350349      ! Garder le seul terme en q_star^2 ? ou rendre negatif le t_star^2 ?
    351       therm(i) = sqrt(b1*(1.+2.*retv*qt_th(i))*t_star**2+(retv*th_th(i))**2*b2*q_star*q_star+2.*retv*th_th(i)*b212* &
    352         q_star*t_star)
     350      therm(i) = sqrt(b1 * (1. + 2. * retv * qt_th(i)) * t_star**2 + (retv * th_th(i))**2 * b2 * q_star * q_star + 2. * retv * th_th(i) * b212 * &
     351              q_star * t_star)
    353352
    354353      ! Theta et qT du thermique (forme H&B) avec exces
    … …  
    356355      ! pourquoi pas sqrt(b1)*t_star ?
    357356      ! dqs = b2sr*kqfs(i)/wm(i)
    358       qt_th(i) = qt_th(i) + b2sr*q_star
     357      qt_th(i) = qt_th(i) + b2sr * q_star
    359358      rhino(i, 1) = 0.0
    360359    END IF
    … …  
    375374        zdu2 = max(zdu2, 1.0E-20)
    376375        ! Theta_v environnement
    377         zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
     376        zthvd = t(i, k) / s(i, k) * (1. + retv * q(i, k))
    378377
    379378        ! et therm Theta_v (avec hypothese de constance de H&B,
    380379        ! qui assimile qT a vapeur)
    381         zthvu = th_th(i)*(1.+retv*qt_th(i)) + therm(i)
     380        zthvu = th_th(i) * (1. + retv * qt_th(i)) + therm(i)
    382381
    383382
    384383        ! Le Ri par Theta_v
    385384        ! AM Niveau de ref 2m
    386         rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5*(zthvd+zthvu))
     385        rhino(i, k) = (z(i, k) - zref) * rg * (zthvd - zthvu) / (zdu2 * 0.5 * (zthvd + zthvu))
    387386
    388387        ! Niveau critique atteint
    389         IF (rhino(i,k)>=ricr) THEN
    390           pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
     388        IF (rhino(i, k)>=ricr) THEN
     389          pblh(i) = z(i, k - 1) + (z(i, k - 1) - z(i, k)) * (ricr - rhino(i, k - 1)) / (rhino(i, k - 1) - rhino(i, k))
    391390          ! test04
    392391          pblh(i) = pblh(i) + 100.
    … …  
    418417  ! Al1 calcul de pblT dans ce cas
    419418  DO i = 1, knon
    420     pblmin = 700.0*ustar(i)
     419    pblmin = 700.0 * ustar(i)
    421420    IF (pblh(i)<pblmin) check(i) = .TRUE.
    422421  END DO
    423422  DO i = 1, knon
    424423    IF (check(i)) THEN
    425       pblh(i) = 700.0*ustar(i)
     424      pblh(i) = 700.0 * ustar(i)
    426425      ! et par exemple :
    427426      ! pblT(i) = t(i,2) + (t(i,3)-t(i,2)) *
    … …  
    445444    IF (unstbl(i)) THEN
    446445      ! Al pblh a change', on recalcule :
    447       zxt = (th_th(i)-zref*0.5*rg/rcpd/(1.+rvtmp2*qt_th(i)))*(1.+retv*qt_th(i))
    448       phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
    449       phihinv(i) = sqrt(1.-binh*pblh(i)/obklen(i))
    450       wm(i) = ustar(i)*phiminv(i)
     446      zxt = (th_th(i) - zref * 0.5 * rg / rcpd / (1. + rvtmp2 * qt_th(i))) * (1. + retv * qt_th(i))
     447      phiminv(i) = (1. - binm * pblh(i) / obklen(i))**onet
     448      phihinv(i) = sqrt(1. - binh * pblh(i) / obklen(i))
     449      wm(i) = ustar(i) * phiminv(i)
    451450    END IF
    452451  END DO
    … …  
    476475      omega(i) = 0.
    477476
    478       phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
    479       wm(i) = ustar(i)*phiminv(i)
    480       q_star = max(0., kqfs(i)/wm(i))
    481       t_star = max(0., khfs(i)/wm(i))
    482       therm(i) = sqrt(b1*(1.+2.*retv*qt_th(i))*t_star**2+(retv*th_th(i))**2*b2*q_star*q_star+2.*retv*th_th(i)*b212* &
    483         q_star*t_star)
     477      phiminv(i) = (1. - binm * pblh(i) / obklen(i))**onet
     478      wm(i) = ustar(i) * phiminv(i)
     479      q_star = max(0., kqfs(i) / wm(i))
     480      t_star = max(0., khfs(i) / wm(i))
     481      therm(i) = sqrt(b1 * (1. + 2. * retv * qt_th(i)) * t_star**2 + (retv * th_th(i))**2 * b2 * q_star * q_star + 2. * retv * th_th(i) * b212 * &
     482              q_star * t_star)
    484483      ! Al1diag
    485484      ! trmb1(i) = b1*(1.+2.*RETV*qT_th(i))*t_star**2
    … …  
    494493      ! trmb3(i) = phiminv(i)
    495494      ! and computes Theta_e for thermal
    496       the_th(i) = th_th(i) + rlvcp*qt_th(i)
     495      the_th(i) = th_th(i) + rlvcp * qt_th(i)
    497496    END IF ! unstbl
    498497    ! Al1 compute a first guess of Plcl with the Bolton/Emanuel formula
    499498    t2 = th_th(i)
    500499    ! thermodyn functions
    501     zdelta = max(0., sign(1.,rtt-t2))
    502     qsat = r2es*foeew(t2, zdelta)/paprs(i, 1)
     500    zdelta = max(0., sign(1., rtt - t2))
     501    qsat = r2es * foeew(t2, zdelta) / paprs(i, 1)
    503502    qsat = min(0.5, qsat)
    504     zcor = 1./(1.-retv*qsat)
    505     qsat = qsat*zcor
     503    zcor = 1. / (1. - retv * qsat)
     504    qsat = qsat * zcor
    506505    ! relative humidity of thermal at 2m
    507     rh = qt_th(i)/qsat
    508     chi = t2/(1669.0-122.0*rh-t2)
    509     plcl(i) = paprs(i, 1)*(rh**chi)
     506    rh = qt_th(i) / qsat
     507    chi = t2 / (1669.0 - 122.0 * rh - t2)
     508    plcl(i) = paprs(i, 1) * (rh**chi)
    510509    ! al1diag
    511510    ! ctei(i) = Plcl(i)
    … …  
    525524      IF (check(i) .OR. omegafl(i)) THEN
    526525        ! CC         if (pplay(i,k) .le. plcl(i)) THEN
    527         zm(i) = z(i, k-1)
     526        zm(i) = z(i, k - 1)
    528527        zp(i) = z(i, k)
    529528        ! Environnement : calcul de Tv1 a partir de t(:,:)== T liquide
    … …  
    531530        tl1 = t(i, k)
    532531        t1 = tl1
    533         zdelta = max(0., sign(1.,rtt-t1))
    534         qsat = r2es*foeew(t1, zdelta)/pplay(i, k)
     532        zdelta = max(0., sign(1., rtt - t1))
     533        qsat = r2es * foeew(t1, zdelta) / pplay(i, k)
    535534        qsat = min(0.5, qsat)
    536         zcor = 1./(1.-retv*qsat)
    537         qsat = qsat*zcor
    538         q1 = min(q(i,k), qsat)
    539         ql1 = max(0., q(i,k)-q1)
     535        zcor = 1. / (1. - retv * qsat)
     536        qsat = qsat * zcor
     537        q1 = min(q(i, k), qsat)
     538        ql1 = max(0., q(i, k) - q1)
    540539        ! thermodyn function (Tl2Tql)
    541         dt = rlvcp*ql1
     540        dt = rlvcp * ql1
    542541        DO WHILE (abs(dt)>=dt0)
    543542          t1 = t1 + dt
    544           zdelta = max(0., sign(1.,rtt-t1))
    545           zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta
    546           qsat = r2es*foeew(t1, zdelta)/pplay(i, k)
     543          zdelta = max(0., sign(1., rtt - t1))
     544          zcvm5 = r5les * (1. - zdelta) + r5ies * zdelta
     545          qsat = r2es * foeew(t1, zdelta) / pplay(i, k)
    547546          qsat = min(0.5, qsat)
    548           zcor = 1./(1.-retv*qsat)
    549           qsat = qsat*zcor
     547          zcor = 1. / (1. - retv * qsat)
     548          qsat = qsat * zcor
    550549          dqsat_dt = foede(t1, zdelta, zcvm5, qsat, zcor)
    551550          ! correction lineaire pour conserver Tl env
    552551          ! << Tl = T1 + DT - RLvCp*(ql1 - dqsat/dT*DT >>
    553           denom = 1. + rlvcp*dqsat_dt
    554           q1 = min(q(i,k), qsat)
     552          denom = 1. + rlvcp * dqsat_dt
     553          q1 = min(q(i, k), qsat)
    555554          ql1 = q(i, k) - q1 ! can be negative
    556           rnum = tl1 - t1 + rlvcp*ql1
    557           dt = rnum/denom
     555          rnum = tl1 - t1 + rlvcp * ql1
     556          dt = rnum / denom
    558557        END DO
    559558        ql1 = max(0., ql1)
    560         tv1 = t1*(1.+retv*q1-ql1)
     559        tv1 = t1 * (1. + retv * q1 - ql1)
    561560        ! Thermique    : on atteint le seuil B/E de condensation
    562561        ! ==============
    … …  
    564563        IF (.NOT. zsat(i)) THEN
    565564          ! first guess from The_th(i) = Th_th(i) + RLvCp* [qv=qT_th(i)]
    566           t2 = s(i, k)*the_th(i) - rlvcp*qt_th(i)
    567           zdelta = max(0., sign(1.,rtt-t2))
    568           qsat = r2es*foeew(t2, zdelta)/pplay(i, k)
     565          t2 = s(i, k) * the_th(i) - rlvcp * qt_th(i)
     566          zdelta = max(0., sign(1., rtt - t2))
     567          qsat = r2es * foeew(t2, zdelta) / pplay(i, k)
    569568          qsat = min(0.5, qsat)
    570           zcor = 1./(1.-retv*qsat)
    571           qsat = qsat*zcor
     569          zcor = 1. / (1. - retv * qsat)
     570          qsat = qsat * zcor
    572571          q2 = min(qt_th(i), qsat)
    573           ql2 = max(0., qt_th(i)-q2)
     572          ql2 = max(0., qt_th(i) - q2)
    574573          IF (ql2>0.0001) zsat(i) = .TRUE.
    575574          tbef(i) = t2
    576575          ! a PBLH non sature
    577576          IF (zm(i)<pblh(i) .AND. zp(i)>=pblh(i)) THEN
    578             reduc = (pblh(i)-zm(i))/(zp(i)-zm(i))
    579             spblh = s(i, k-1) + reduc*(s(i,k)-s(i,k-1))
     577            reduc = (pblh(i) - zm(i)) / (zp(i) - zm(i))
     578            spblh = s(i, k - 1) + reduc * (s(i, k) - s(i, k - 1))
    580579            ! lmdz : qT1 et Thv1
    581             t1 = (t(i,k-1)+reduc*(t(i,k)-t(i,k-1)))
    582             thv1 = t1*(1.+retv*q(i,k))/spblh
     580            t1 = (t(i, k - 1) + reduc * (t(i, k) - t(i, k - 1)))
     581            thv1 = t1 * (1. + retv * q(i, k)) / spblh
    583582            ! on calcule pour le cas sans nuage un ctei en Delta Thv
    584             thv2 = t2/spblh*(1.+retv*qt_th(i))
     583            thv2 = t2 / spblh * (1. + retv * qt_th(i))
    585584            ctei(i) = thv1 - thv2
    586             tv2 = t2*(1.+retv*q2-ql2)
     585            tv2 = t2 * (1. + retv * q2 - ql2)
    587586            ! diag
    588587            ! dTv21(i,k) = Tv2-Tv1
    … …  
    596595          t2 = tbef(i)
    597596          dt = 1.
    598           te2 = s(i, k)*the_th(i)
     597          te2 = s(i, k) * the_th(i)
    599598          DO WHILE (abs(dt)>=dt0)
    600             zdelta = max(0., sign(1.,rtt-t2))
    601             zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta
    602             qsat = r2es*foeew(t2, zdelta)/pplay(i, k)
     599            zdelta = max(0., sign(1., rtt - t2))
     600            zcvm5 = r5les * (1. - zdelta) + r5ies * zdelta
     601            qsat = r2es * foeew(t2, zdelta) / pplay(i, k)
    603602            qsat = min(0.5, qsat)
    604             zcor = 1./(1.-retv*qsat)
    605             qsat = qsat*zcor
     603            zcor = 1. / (1. - retv * qsat)
     604            qsat = qsat * zcor
    606605            dqsat_dt = foede(t2, zdelta, zcvm5, qsat, zcor)
    607606            ! correction lineaire pour conserver Te_th
    608607            ! << Te = T2 + DT + RLvCp*(qsatbef + dq/dT*DT >>
    609             denom = 1. + rlvcp*dqsat_dt
    610             rnum = te2 - t2 - rlvcp*qsat
    611             dt = rnum/denom
     608            denom = 1. + rlvcp * dqsat_dt
     609            rnum = te2 - t2 - rlvcp * qsat
     610            dt = rnum / denom
    612611            t2 = t2 + dt
    613612          END DO
    614613          q2 = min(qt_th(i), qsat)
    615           ql2 = max(0., qt_th(i)-q2)
     614          ql2 = max(0., qt_th(i) - q2)
    616615          ! jusqu'a PBLH y compris
    617616          IF (zm(i)<pblh(i)) THEN
    … …  
    619618            ! mais a PBLH, interpolation et complements
    620619            IF (zp(i)>=pblh(i)) THEN
    621               reduc = (pblh(i)-zm(i))/(zp(i)-zm(i))
    622               spblh = s(i, k-1) + reduc*(s(i,k)-s(i,k-1))
     620              reduc = (pblh(i) - zm(i)) / (zp(i) - zm(i))
     621              spblh = s(i, k - 1) + reduc * (s(i, k) - s(i, k - 1))
    623622              ! CAPE et EauLiq a pblH
    624               cape(i) = kape(i) + reduc*(zp(i)-zm(i))*rg*.5/(tv2+tv1)*max(0., (tv2-tv1))
    625               eauliq(i) = eauliq(i) + reduc*(paprs(i,k-1)-paprs(i,k))*ql2/rg
     623              cape(i) = kape(i) + reduc * (zp(i) - zm(i)) * rg * .5 / (tv2 + tv1) * max(0., (tv2 - tv1))
     624              eauliq(i) = eauliq(i) + reduc * (paprs(i, k - 1) - paprs(i, k)) * ql2 / rg
    626625              ! CTEI
    627               the2 = (t2+rlvcp*q2)/spblh
     626              the2 = (t2 + rlvcp * q2) / spblh
    628627              ! T1 est en realite la Tl env (on a donc strict The1)
    629               t1 = (t(i,k-1)+reduc*(t(i,k)-t(i,k-1)))
    630               the1 = (t1+rlvcp*q(i,k))/spblh
     628              t1 = (t(i, k - 1) + reduc * (t(i, k) - t(i, k - 1)))
     629              the1 = (t1 + rlvcp * q(i, k)) / spblh
    631630              ! Calcul de la Cloud Top Entrainement Instability
    632631              ! cf Mathieu Lahellec QJRMS (2005) Comments to DYCOMS-II
    … …  
    635634              delt_qt = q(i, k) - qt_th(i) ! negatif
    636635              d_qt(i) = -delt_qt
    637               dlt_2(i) = .63*delt_the - the2*delt_qt
     636              dlt_2(i) = .63 * delt_the - the2 * delt_qt
    638637              ! init ctei(i)
    639638              ctei(i) = dlt_2(i)
    640639              IF (dlt_2(i)<-0.1) THEN
    641640                ! integrale de Peter :
    642                 aa = delt_the - delt_qt*(rlvcp-retv*the2)
    643                 bb = (rlvcp-(1.+retv)*the2)*ql2
     641                aa = delt_the - delt_qt * (rlvcp - retv * the2)
     642                bb = (rlvcp - (1. + retv) * the2) * ql2
    644643                d_thv(i) = aa - bb
    645644                ! approx de Xhi_s et de l'integrale Xint=ctei(i)
    646                 xhis(i) = bb/(aa-dlt_2(i))
     645                xhis(i) = bb / (aa - dlt_2(i))
    647646                ! trmb1(i) = xhis
    648647                ! trmb3(i) = dlt_2
    649                 xnull = bb/aa
     648                xnull = bb / aa
    650649                IF (xhis(i)>0.1) THEN
    651                   ctei(i) = dlt_2(i)*xhis(i) + aa*(1.-xhis(i)) + bb*alog(xhis(i))
     650                  ctei(i) = dlt_2(i) * xhis(i) + aa * (1. - xhis(i)) + bb * alog(xhis(i))
    652651                ELSE
    653                   ctei(i) = .5*(dlt_2(i)+aa-bb)
     652                  ctei(i) = .5 * (dlt_2(i) + aa - bb)
    654653                END IF
    655654                IF (xnull>0.) THEN
    656                   posint(i) = aa - bb + bb*alog(xnull)
     655                  posint(i) = aa - bb + bb * alog(xnull)
    657656                ELSE
    658657                  posint(i) = 0.
    … …  
    665664              omegafl(i) = .TRUE.
    666665            END IF ! end a pblh
    667             IF (check(i)) eauliq(i) = eauliq(i) + (paprs(i,k)-paprs(i,k+1))*ql2/rg
     666            IF (check(i)) eauliq(i) = eauliq(i) + (paprs(i, k) - paprs(i, k + 1)) * ql2 / rg
    668667          END IF
    669668
    … …  
    671670
    672671        ! KAPE : thermique / environnement
    673         tv2 = t2*(1.+retv*q2-ql2)
     672        tv2 = t2 * (1. + retv * q2 - ql2)
    674673        ! diag
    675674        ! dTv21(i,k) = Tv2-Tv1
    676675        ! Kape courante
    677         kape(i) = kape(i) + (zp(i)-zm(i))*rg*.5/(tv2+tv1)*max(0., (tv2-tv1))
     676        kape(i) = kape(i) + (zp(i) - zm(i)) * rg * .5 / (tv2 + tv1) * max(0., (tv2 - tv1))
    678677        ! Cin
    679         IF (zcin(i) .AND. tv2-tv1>0.) THEN
     678        IF (zcin(i) .AND. tv2 - tv1>0.) THEN
    680679          zcin(i) = .FALSE.
    681680          cin(i) = kin(i)
    682681        END IF
    683         IF (.NOT. zcin(i) .AND. tv2-tv1<0.) THEN
     682        IF (.NOT. zcin(i) .AND. tv2 - tv1<0.) THEN
    684683          zcin(i) = .TRUE.
    685           kin(i) = kin(i) + (zp(i)-zm(i))*rg*.5/(tv2+tv1)*min(0., (tv2-tv1))
     684          kin(i) = kin(i) + (zp(i) - zm(i)) * rg * .5 / (tv2 + tv1) * min(0., (tv2 - tv1))
    686685        END IF
    687         IF (kape(i)+kin(i)<0.) THEN
     686        IF (kape(i) + kin(i)<0.) THEN
    688687          omega(i) = zm(i)
    689688          ! trmb3(i) = paprs(i,k)

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

    r5119 r5143  
    66
    77  SUBROUTINE hbtm(knon, paprs, pplay, t2m, t10m, q2m, q10m, ustar, wstar, &
    8        flux_t, flux_q, u, v, t, q, pblh, cape, eauliq, ctei, pblt, therm, &
    9        trmb1, trmb2, trmb3, plcl)
     8          flux_t, flux_q, u, v, t, q, pblh, cape, eauliq, ctei, pblt, therm, &
     9          trmb1, trmb2, trmb3, plcl)
    1010    USE dimphy
     11    USE lmdz_YOETHF
     12    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    1113
    1214    ! ***************************************************************
    … …  
    3840    ! forme de HB avec le 1er niveau modele etait conservee)
    3941
    40 
    41 
    42 
    43 
    4442    include "YOMCST.h"
    4543    REAL rlvcp, reps
    … …  
    5250    REAL ustar(klon)
    5351    REAL wstar(klon) ! w*, convective velocity scale
    54     REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
     52    REAL paprs(klon, klev + 1) ! pression a inter-couche (Pa)
    5553    REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
    5654    REAL flux_t(klon, klev), flux_q(klon, klev) ! Flux
    … …  
    6866    REAL, PARAMETER :: fak = 8.5 ! b calcul du Prandtl et de dTetas
    6967    REAL, PARAMETER :: fakn = 7.2 ! a
    70     REAL, PARAMETER :: onet = 1.0/3.0
     68    REAL, PARAMETER :: onet = 1.0 / 3.0
    7169    REAL, PARAMETER :: t_coup = 273.15
    7270    REAL, PARAMETER :: zkmin = 0.01
    … …  
    7977    REAL, PARAMETER :: sffrac = 0.1 ! S.L. = z/h < .1
    8078    REAL, PARAMETER :: usmin = 1.E-12
    81     REAL, PARAMETER :: binm = betam*sffrac
    82     REAL, PARAMETER :: binh = betah*sffrac
    83     REAL, PARAMETER :: ccon = fak*sffrac*vk
     79    REAL, PARAMETER :: binm = betam * sffrac
     80    REAL, PARAMETER :: binh = betah * sffrac
     81    REAL, PARAMETER :: ccon = fak * sffrac * vk
    8482    REAL, PARAMETER :: b1 = 70., b2 = 20.
    8583    REAL, PARAMETER :: zref = 2. ! Niveau de ref a 2m peut eventuellement
    … …  
    114112    ! AM      REAL ztvd, ztvu,
    115113    REAL zdu2
    116     REAL, INTENT(OUT):: therm(:) ! (klon) thermal virtual temperature excess
     114    REAL, INTENT(OUT) :: therm(:) ! (klon) thermal virtual temperature excess
    117115    REAL trmb1(klon), trmb2(klon), trmb3(klon)
    118116    ! Algorithme thermique
    … …  
    153151    REAL fac, pblmin, zmzp, term
    154152
    155     include "YOETHF.h"
    156     include "FCTTRE.h"
    157 
    158 
    159 
    160153    ! initialisations (Anne)
    161154    isommet = klev
    … …  
    165158    therm = 0.
    166159
    167     b212 = sqrt(b1*b2)
     160    b212 = sqrt(b1 * b2)
    168161    b2sr = sqrt(b2)
    169162
    … …  
    191184
    192185    ! Initialisation
    193     rlvcp = rlvtt/rcpd
    194     reps = rd/rv
     186    rlvcp = rlvtt / rcpd
     187    reps = rd / rv
    195188
    196189
    … …  
    213206    ! pourquoi ne pas utiliser Phi/RG ?
    214207    DO i = 1, knon
    215        z(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i,1)))&
    216             *(paprs(i,1)-pplay(i,1))/rg
    217        s(i, 1) = (pplay(i,1)/paprs(i,1))**rkappa
     208      z(i, 1) = rd * t(i, 1) / (0.5 * (paprs(i, 1) + pplay(i, 1)))&
     209              * (paprs(i, 1) - pplay(i, 1)) / rg
     210      s(i, 1) = (pplay(i, 1) / paprs(i, 1))**rkappa
    218211    END DO
    219212    ! s(k) = [pplay(k)/ps]^kappa
    … …  
    230223
    231224    DO k = 2, klev
    232        DO i = 1, knon
    233           z(i, k) = z(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)&
    234                *(pplay(i,k-1)-pplay(i,k))/rg
    235           s(i, k) = (pplay(i,k)/paprs(i,1))**rkappa
    236        END DO
     225      DO i = 1, knon
     226        z(i, k) = z(i, k - 1) + rd * 0.5 * (t(i, k - 1) + t(i, k)) / paprs(i, k)&
     227                * (pplay(i, k - 1) - pplay(i, k)) / rg
     228        s(i, k) = (pplay(i, k) / paprs(i, 1))**rkappa
     229      END DO
    237230    END DO
    238231    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    … …  
    242235    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    243236    DO i = 1, knon
    244        ! AM         IF (thermcep) THEN
    245        ! AM           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
    246        ! zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
    247        ! zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
    248        ! AM           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
    249        ! AM           zxqs=MIN(0.5,zxqs)
    250        ! AM           zcor=1./(1.-retv*zxqs)
    251        ! AM           zxqs=zxqs*zcor
    252        ! AM         ELSE
    253        ! AM           IF (tsol(i).LT.t_coup) THEN
    254        ! AM              zxqs = qsats(tsol(i)) / paprs(i,1)
    255        ! AM           ELSE
    256        ! AM              zxqs = qsatl(tsol(i)) / paprs(i,1)
    257        ! AM           ENDIF
    258        ! AM         ENDIF
    259        ! niveau de reference bulk; mais ici, c,a pourrait etre le niveau de ref
    260        ! du thermique
    261        ! AM        zx_alf1 = 1.0
    262        ! AM        zx_alf2 = 1.0 - zx_alf1
    263        ! AM        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
    264        ! AM     .        *(1.+RETV*q(i,1))*zx_alf1
    265        ! AM     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
    266        ! AM     .        *(1.+RETV*q(i,2))*zx_alf2
    267        ! AM        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
    268        ! AM        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
    269        ! AM        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
    270        ! AM
    271        ! AMAM           zxu = u10m(i)
    272        ! AMAM           zxv = v10m(i)
    273        ! AMAM           zxmod = 1.0+SQRT(zxu**2+zxv**2)
    274        ! AM Niveau de ref choisi a 2m
    275        zxt = t2m(i)
    276 
    277        ! ***************************************************
    278        ! attention, il doit s'agir de <w'theta'>
    279        ! ;Calcul de tcls virtuel et de w'theta'virtuel
    280        ! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    281        ! tcls=tcls*(1+.608*qcls)
    282 
    283        ! ;Pour avoir w'theta',
    284        ! ; il faut diviser par ro.Cp
    285        ! Cp=Cpd*(1+0.84*qcls)
    286        ! fcs=fcs/(ro_surf*Cp)
    287        ! ;On transforme w'theta' en w'thetav'
    288        ! Lv=(2.501-0.00237*(tcls-273.15))*1.E6
    289        ! xle=xle/(ro_surf*Lv)
    290        ! fcsv=fcs+.608*xle*tcls
    291        ! ***************************************************
    292        ! AM        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
    293        ! AM        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
    294        ! AM
    295        ! dif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i)
    296        ! AM calcule de Ro = paprs(i,1)/Rd zxt
    297        ! AM convention >0 vers le bas ds lmdz
    298        khfs(i) = -flux_t(i, 1)*zxt*rd/(rcpd*paprs(i,1))
    299        kqfs(i) = -flux_q(i, 1)*zxt*rd/(paprs(i,1))
    300        ! AM   verifier que khfs et kqfs sont bien de la forme w'l'
    301        heatv(i) = khfs(i) + 0.608*zxt*kqfs(i)
    302        ! a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
    303        ! AM        heatv(i) = khfs(i)
    304        ! AM ustar est en entree
    305        ! AM        taux = zxu *zxmod*cd_m(i)
    306        ! AM        tauy = zxv *zxmod*cd_m(i)
    307        ! AM        ustar(i) = SQRT(taux**2+tauy**2)
    308        ! AM        ustar(i) = MAX(SQRT(ustar(i)),0.01)
    309        ! Theta et qT du thermique sans exces (interpolin vers surf)
    310        ! chgt de niveau du thermique (jeudi 30/12/1999)
    311        ! (interpolation lineaire avant integration phi_h)
    312        ! AM        qT_th(i) = zxqs*beta(i) + 4./z(i,1)*(q(i,1)-zxqs*beta(i))
    313        ! AM        qT_th(i) = max(qT_th(i),q(i,1))
    314        qt_th(i) = q2m(i)
    315        ! n The_th restera la Theta du thermique sans exces jusqu'a 2eme calcul
    316        ! n reste a regler convention P) pour Theta
    317        ! The_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
    318        ! -                      + RLvCp*qT_th(i)
    319        ! AM        Th_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
    320        th_th(i) = t2m(i)
    321     END DO
    322 
    323     DO i = 1, knon
    324        rhino(i, 1) = 0.0 ! Global Richardson
    325        check(i) = .TRUE.
    326        pblh(i) = z(i, 1) ! on initialise pblh a l'altitude du 1er niveau
    327        plcl(i) = 6000.
    328        ! Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
    329        unsobklen(i) = -rg*vk*heatv(i)/(t(i,1)*max(ustar(i),usmin)**3)
    330        trmb1(i) = 0.
    331        trmb2(i) = 0.
    332        trmb3(i) = 0.
     237      ! AM         IF (thermcep) THEN
     238      ! AM           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
     239      ! zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
     240      ! zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
     241      ! AM           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
     242      ! AM           zxqs=MIN(0.5,zxqs)
     243      ! AM           zcor=1./(1.-retv*zxqs)
     244      ! AM           zxqs=zxqs*zcor
     245      ! AM         ELSE
     246      ! AM           IF (tsol(i).LT.t_coup) THEN
     247      ! AM              zxqs = qsats(tsol(i)) / paprs(i,1)
     248      ! AM           ELSE
     249      ! AM              zxqs = qsatl(tsol(i)) / paprs(i,1)
     250      ! AM           ENDIF
     251      ! AM         ENDIF
     252      ! niveau de reference bulk; mais ici, c,a pourrait etre le niveau de ref
     253      ! du thermique
     254      ! AM        zx_alf1 = 1.0
     255      ! AM        zx_alf2 = 1.0 - zx_alf1
     256      ! AM        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
     257      ! AM     .        *(1.+RETV*q(i,1))*zx_alf1
     258      ! AM     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
     259      ! AM     .        *(1.+RETV*q(i,2))*zx_alf2
     260      ! AM        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
     261      ! AM        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
     262      ! AM        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
     263      ! AM
     264      ! AMAM           zxu = u10m(i)
     265      ! AMAM           zxv = v10m(i)
     266      ! AMAM           zxmod = 1.0+SQRT(zxu**2+zxv**2)
     267      ! AM Niveau de ref choisi a 2m
     268      zxt = t2m(i)
     269
     270      ! ***************************************************
     271      ! attention, il doit s'agir de <w'theta'>
     272      ! ;Calcul de tcls virtuel et de w'theta'virtuel
     273      ! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     274      ! tcls=tcls*(1+.608*qcls)
     275
     276      ! ;Pour avoir w'theta',
     277      ! ; il faut diviser par ro.Cp
     278      ! Cp=Cpd*(1+0.84*qcls)
     279      ! fcs=fcs/(ro_surf*Cp)
     280      ! ;On transforme w'theta' en w'thetav'
     281      ! Lv=(2.501-0.00237*(tcls-273.15))*1.E6
     282      ! xle=xle/(ro_surf*Lv)
     283      ! fcsv=fcs+.608*xle*tcls
     284      ! ***************************************************
     285      ! AM        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
     286      ! AM        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
     287      ! AM
     288      ! dif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i)
     289      ! AM calcule de Ro = paprs(i,1)/Rd zxt
     290      ! AM convention >0 vers le bas ds lmdz
     291      khfs(i) = -flux_t(i, 1) * zxt * rd / (rcpd * paprs(i, 1))
     292      kqfs(i) = -flux_q(i, 1) * zxt * rd / (paprs(i, 1))
     293      ! AM   verifier que khfs et kqfs sont bien de la forme w'l'
     294      heatv(i) = khfs(i) + 0.608 * zxt * kqfs(i)
     295      ! a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
     296      ! AM        heatv(i) = khfs(i)
     297      ! AM ustar est en entree
     298      ! AM        taux = zxu *zxmod*cd_m(i)
     299      ! AM        tauy = zxv *zxmod*cd_m(i)
     300      ! AM        ustar(i) = SQRT(taux**2+tauy**2)
     301      ! AM        ustar(i) = MAX(SQRT(ustar(i)),0.01)
     302      ! Theta et qT du thermique sans exces (interpolin vers surf)
     303      ! chgt de niveau du thermique (jeudi 30/12/1999)
     304      ! (interpolation lineaire avant integration phi_h)
     305      ! AM        qT_th(i) = zxqs*beta(i) + 4./z(i,1)*(q(i,1)-zxqs*beta(i))
     306      ! AM        qT_th(i) = max(qT_th(i),q(i,1))
     307      qt_th(i) = q2m(i)
     308      ! n The_th restera la Theta du thermique sans exces jusqu'a 2eme calcul
     309      ! n reste a regler convention P) pour Theta
     310      ! The_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
     311      ! -                      + RLvCp*qT_th(i)
     312      ! AM        Th_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
     313      th_th(i) = t2m(i)
     314    END DO
     315
     316    DO i = 1, knon
     317      rhino(i, 1) = 0.0 ! Global Richardson
     318      check(i) = .TRUE.
     319      pblh(i) = z(i, 1) ! on initialise pblh a l'altitude du 1er niveau
     320      plcl(i) = 6000.
     321      ! Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
     322      unsobklen(i) = -rg * vk * heatv(i) / (t(i, 1) * max(ustar(i), usmin)**3)
     323      trmb1(i) = 0.
     324      trmb2(i) = 0.
     325      trmb3(i) = 0.
    333326    END DO
    334327
    … …  
    342335    fac = 100.0
    343336    DO k = 2, isommet
    344        DO i = 1, knon
    345           IF (check(i)) THEN
    346              ! pourquoi / niveau 1 (au lieu du sol) et le terme en u*^2 ?
    347              ! test     zdu2 =
    348              ! (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
    349              zdu2 = u(i, k)**2 + v(i, k)**2
    350              zdu2 = max(zdu2, 1.0E-20)
    351              ! Theta_v environnement
    352              zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
    353 
    354              ! therm Theta_v sans exces (avec hypothese fausse de H&B, sinon,
    355              ! passer par Theta_e et virpot)
    356              ! zthvu=t(i,1)/s(i,1)*(1.+RETV*q(i,1))
    357              ! AM         zthvu = Th_th(i)*(1.+RETV*q(i,1))
    358              zthvu = th_th(i)*(1.+retv*qt_th(i))
    359              ! Le Ri par Theta_v
    360              ! AM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
    361              ! AM     .               /(zdu2*0.5*(zthvd+zthvu))
    362              ! AM On a nveau de ref a 2m ???
    363              rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5&
    364                   *(zthvd+zthvu))
    365 
    366              IF (rhino(i,k)>=ricr) THEN
    367                 pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))&
    368                      /(rhino(i,k-1)-rhino(i,k))
    369                 ! test04
    370                 pblh(i) = pblh(i) + 100.
    371                 pblt(i) = t(i, k-1) + (t(i,k)-t(i,k-1))*(pblh(i)-z(i,k-1))&
    372                      /(z(i,k)- z(i,k-1))
    373                 check(i) = .FALSE.
    374              END IF
     337      DO i = 1, knon
     338        IF (check(i)) THEN
     339          ! pourquoi / niveau 1 (au lieu du sol) et le terme en u*^2 ?
     340          ! test     zdu2 =
     341          ! (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
     342          zdu2 = u(i, k)**2 + v(i, k)**2
     343          zdu2 = max(zdu2, 1.0E-20)
     344          ! Theta_v environnement
     345          zthvd = t(i, k) / s(i, k) * (1. + retv * q(i, k))
     346
     347          ! therm Theta_v sans exces (avec hypothese fausse de H&B, sinon,
     348          ! passer par Theta_e et virpot)
     349          ! zthvu=t(i,1)/s(i,1)*(1.+RETV*q(i,1))
     350          ! AM         zthvu = Th_th(i)*(1.+RETV*q(i,1))
     351          zthvu = th_th(i) * (1. + retv * qt_th(i))
     352          ! Le Ri par Theta_v
     353          ! AM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
     354          ! AM     .               /(zdu2*0.5*(zthvd+zthvu))
     355          ! AM On a nveau de ref a 2m ???
     356          rhino(i, k) = (z(i, k) - zref) * rg * (zthvd - zthvu) / (zdu2 * 0.5&
     357                  * (zthvd + zthvu))
     358
     359          IF (rhino(i, k)>=ricr) THEN
     360            pblh(i) = z(i, k - 1) + (z(i, k - 1) - z(i, k)) * (ricr - rhino(i, k - 1))&
     361                    / (rhino(i, k - 1) - rhino(i, k))
     362            ! test04
     363            pblh(i) = pblh(i) + 100.
     364            pblt(i) = t(i, k - 1) + (t(i, k) - t(i, k - 1)) * (pblh(i) - z(i, k - 1))&
     365                    / (z(i, k) - z(i, k - 1))
     366            check(i) = .FALSE.
    375367          END IF
    376        END DO
     368        END IF
     369      END DO
    377370    END DO
    378371
    … …  
    382375
    383376    DO i = 1, knon
    384        IF (check(i)) pblh(i) = z(i, isommet)
     377      IF (check(i)) pblh(i) = z(i, isommet)
    385378    END DO
    386379
    … …  
    389382
    390383    DO i = 1, knon
    391        IF (heatv(i)>0.) THEN
    392           unstbl(i) = .TRUE.
    393           check(i) = .TRUE.
    394        ELSE
    395           unstbl(i) = .FALSE.
    396           check(i) = .FALSE.
    397        END IF
     384      IF (heatv(i)>0.) THEN
     385        unstbl(i) = .TRUE.
     386        check(i) = .TRUE.
     387      ELSE
     388        unstbl(i) = .FALSE.
     389        check(i) = .FALSE.
     390      END IF
    398391    END DO
    399392
    … …  
    402395
    403396    DO i = 1, knon
    404        IF (check(i)) THEN
    405           phiminv(i) = (1.-binm*pblh(i)*unsobklen(i))**onet
    406           ! ***************************************************
    407           ! Wm ? et W* ? c'est la formule pour z/h < .1
    408           ! ;Calcul de w* ;;
    409           ! ;;;;;;;;;;;;;;;;
    410           ! w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx
    411           ! de h)
    412           ! ;; CALCUL DE wm ;;
    413           ! ;;;;;;;;;;;;;;;;;;
    414           ! ; Ici on considerera que l'on est dans la couche de surf jusqu'a
    415           ! 100 m
    416           ! ; On prend svt couche de surface=0.1*h mais on ne connait pas h
    417           ! ;;;;;;;;;;;Dans la couche de surface
    418           ! if (z(ind) le 20) then begin
    419           ! Phim=(1.-15.*(z(ind)/L))^(-1/3.)
    420           ! wm=u_star/Phim
    421           ! ;;;;;;;;;;;En dehors de la couche de surface
    422           ! END IF ELSE IF (z(ind) gt 20) then begin
    423           ! wm=(u_star^3+c1*w_star^3)^(1/3.)
    424           ! END IF
    425           ! ***************************************************
    426           wm(i) = ustar(i)*phiminv(i)
    427           ! ===================================================================
    428           ! valeurs de Dominique Lambert de la campagne SEMAPHORE :
    429           ! <T'^2> = 100.T*^2; <q'^2> = 20.q*^2 a 10m
    430           ! <Tv'^2> = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* +
    431           ! (.608*Tv)^2*20.q*^2;
    432           ! et dTetavS = sqrt(<Tv'^2>) ainsi calculee.
    433           ! avec : T*=<w'T'>_s/w* et q*=<w'q'>/w*
    434           ! !!! on peut donc utiliser w* pour les fluctuations <-> Lambert
    435           ! (leur corellation pourrait dependre de beta par ex)
    436           ! if fcsv(i,j) gt 0 then begin
    437           ! dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$
    438           ! (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$
    439           ! 2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)
    440           ! /wm(i,j))
    441           ! dqs=b2*(xle(i,j)/wm(i,j))^2
    442           ! theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs)
    443           ! q_s(i,j)=q_10(i,j)+sqrt(dqs)
    444           ! END IF else begin
    445           ! Theta_s(i,j)=thetav_10(i,j)
    446           ! q_s(i,j)=q_10(i,j)
    447           ! endelse
    448           ! ===================================================================
    449 
    450           ! HBTM        therm(i) = heatv(i)*fak/wm(i)
    451           ! forme Mathieu :
    452           q_star = kqfs(i)/wm(i)
    453           t_star = khfs(i)/wm(i)
    454           ! IM 091204 BEG
    455           IF (1==0) THEN
    456              IF (t_star<0. .OR. q_star<0.) THEN
    457                 PRINT *, 'i t_star q_star khfs kqfs wm', i, t_star, q_star, &
    458                      khfs(i), kqfs(i), wm(i)
    459              END IF
     397      IF (check(i)) THEN
     398        phiminv(i) = (1. - binm * pblh(i) * unsobklen(i))**onet
     399        ! ***************************************************
     400        ! Wm ? et W* ? c'est la formule pour z/h < .1
     401        ! ;Calcul de w* ;;
     402        ! ;;;;;;;;;;;;;;;;
     403        ! w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx
     404        ! de h)
     405        ! ;; CALCUL DE wm ;;
     406        ! ;;;;;;;;;;;;;;;;;;
     407        ! ; Ici on considerera que l'on est dans la couche de surf jusqu'a
     408        ! 100 m
     409        ! ; On prend svt couche de surface=0.1*h mais on ne connait pas h
     410        ! ;;;;;;;;;;;Dans la couche de surface
     411        ! if (z(ind) le 20) then begin
     412        ! Phim=(1.-15.*(z(ind)/L))^(-1/3.)
     413        ! wm=u_star/Phim
     414        ! ;;;;;;;;;;;En dehors de la couche de surface
     415        ! END IF ELSE IF (z(ind) gt 20) then begin
     416        ! wm=(u_star^3+c1*w_star^3)^(1/3.)
     417        ! END IF
     418        ! ***************************************************
     419        wm(i) = ustar(i) * phiminv(i)
     420        ! ===================================================================
     421        ! valeurs de Dominique Lambert de la campagne SEMAPHORE :
     422        ! <T'^2> = 100.T*^2; <q'^2> = 20.q*^2 a 10m
     423        ! <Tv'^2> = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* +
     424        ! (.608*Tv)^2*20.q*^2;
     425        ! et dTetavS = sqrt(<Tv'^2>) ainsi calculee.
     426        ! avec : T*=<w'T'>_s/w* et q*=<w'q'>/w*
     427        ! !!! on peut donc utiliser w* pour les fluctuations <-> Lambert
     428        ! (leur corellation pourrait dependre de beta par ex)
     429        ! if fcsv(i,j) gt 0 then begin
     430        ! dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$
     431        ! (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$
     432        ! 2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)
     433        ! /wm(i,j))
     434        ! dqs=b2*(xle(i,j)/wm(i,j))^2
     435        ! theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs)
     436        ! q_s(i,j)=q_10(i,j)+sqrt(dqs)
     437        ! END IF else begin
     438        ! Theta_s(i,j)=thetav_10(i,j)
     439        ! q_s(i,j)=q_10(i,j)
     440        ! endelse
     441        ! ===================================================================
     442
     443        ! HBTM        therm(i) = heatv(i)*fak/wm(i)
     444        ! forme Mathieu :
     445        q_star = kqfs(i) / wm(i)
     446        t_star = khfs(i) / wm(i)
     447        ! IM 091204 BEG
     448        IF (1==0) THEN
     449          IF (t_star<0. .OR. q_star<0.) THEN
     450            PRINT *, 'i t_star q_star khfs kqfs wm', i, t_star, q_star, &
     451                    khfs(i), kqfs(i), wm(i)
    460452          END IF
    461           ! IM 091204 END
    462           ! AM Nveau cde ref 2m =>
    463           ! AM        therm(i) = sqrt( b1*(1.+2.*RETV*q(i,1))*t_star**2
    464           ! AM     +             + (RETV*T(i,1))**2*b2*q_star**2
    465           ! AM     +             + 2.*RETV*T(i,1)*b212*q_star*t_star
    466           ! AM     +                 )
    467           ! IM 091204 BEG
    468           a1 = b1*(1.+2.*retv*qt_th(i))*t_star**2
    469           a2 = (retv*th_th(i))**2*b2*q_star*q_star
    470           a3 = 2.*retv*th_th(i)*b212*q_star*t_star
    471           aa = a1 + a2 + a3
    472           IF (1==0) THEN
    473              IF (aa<0.) THEN
    474                 PRINT *, 'i a1 a2 a3 aa', i, a1, a2, a3, aa
    475                 PRINT *, 'i qT_th Th_th t_star q_star RETV b1 b2 b212', i, &
    476                      qt_th(i), th_th(i), t_star, q_star, retv, b1, b2, b212
    477              END IF
     453        END IF
     454        ! IM 091204 END
     455        ! AM Nveau cde ref 2m =>
     456        ! AM        therm(i) = sqrt( b1*(1.+2.*RETV*q(i,1))*t_star**2
     457        ! AM     +             + (RETV*T(i,1))**2*b2*q_star**2
     458        ! AM     +             + 2.*RETV*T(i,1)*b212*q_star*t_star
     459        ! AM     +                 )
     460        ! IM 091204 BEG
     461        a1 = b1 * (1. + 2. * retv * qt_th(i)) * t_star**2
     462        a2 = (retv * th_th(i))**2 * b2 * q_star * q_star
     463        a3 = 2. * retv * th_th(i) * b212 * q_star * t_star
     464        aa = a1 + a2 + a3
     465        IF (1==0) THEN
     466          IF (aa<0.) THEN
     467            PRINT *, 'i a1 a2 a3 aa', i, a1, a2, a3, aa
     468            PRINT *, 'i qT_th Th_th t_star q_star RETV b1 b2 b212', i, &
     469                    qt_th(i), th_th(i), t_star, q_star, retv, b1, b2, b212
    478470          END IF
    479           ! IM 091204 END
    480           therm(i) = sqrt(b1*(1.+2.*retv*qt_th(i))*t_star**2+(retv*th_th( &
    481                i))**2*b2*q_star*q_star &  ! IM 101204  +             +
    482                                 ! 2.*RETV*Th_th(i)*b212*q_star*t_star
    483                +max(0.,2.*retv*th_th(i)*b212*q_star*t_star))
    484 
    485           ! Theta et qT du thermique (forme H&B) avec exces
    486           ! (attention, on ajoute therm(i) qui est virtuelle ...)
    487           ! pourquoi pas sqrt(b1)*t_star ?
    488           ! dqs = b2sr*kqfs(i)/wm(i)
    489           qt_th(i) = qt_th(i) + b2sr*q_star
    490           ! new on differre le calcul de Theta_e
    491           ! The_th(i) = The_th(i) + therm(i) + RLvCp*qT_th(i)
    492           ! ou:    The_th(i) = The_th(i) + sqrt(b1)*khfs(i)/wm(i) +
    493           ! RLvCp*qT_th(i)
    494           rhino(i, 1) = 0.0
    495        END IF
     471        END IF
     472        ! IM 091204 END
     473        therm(i) = sqrt(b1 * (1. + 2. * retv * qt_th(i)) * t_star**2 + (retv * th_th(&
     474                i))**2 * b2 * q_star * q_star &  ! IM 101204  +             +
     475                ! 2.*RETV*Th_th(i)*b212*q_star*t_star
     476                + max(0., 2. * retv * th_th(i) * b212 * q_star * t_star))
     477
     478        ! Theta et qT du thermique (forme H&B) avec exces
     479        ! (attention, on ajoute therm(i) qui est virtuelle ...)
     480        ! pourquoi pas sqrt(b1)*t_star ?
     481        ! dqs = b2sr*kqfs(i)/wm(i)
     482        qt_th(i) = qt_th(i) + b2sr * q_star
     483        ! new on differre le calcul de Theta_e
     484        ! The_th(i) = The_th(i) + therm(i) + RLvCp*qT_th(i)
     485        ! ou:    The_th(i) = The_th(i) + sqrt(b1)*khfs(i)/wm(i) +
     486        ! RLvCp*qT_th(i)
     487        rhino(i, 1) = 0.0
     488      END IF
    496489    END DO
    497490
    … …  
    504497
    505498    DO k = 2, isommet
    506        DO i = 1, knon
    507           IF (check(i)) THEN
    508              ! test     zdu2 =
    509              ! (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
    510              zdu2 = u(i, k)**2 + v(i, k)**2
    511              zdu2 = max(zdu2, 1.0E-20)
    512              ! Theta_v environnement
    513              zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
    514 
    515              ! et therm Theta_v (avec hypothese de constance de H&B,
    516              ! zthvu=(t(i,1)+therm(i))/s(i,1)*(1.+RETV*q(i,1))
    517              zthvu = th_th(i)*(1.+retv*qt_th(i)) + therm(i)
    518 
    519 
    520              ! Le Ri par Theta_v
    521              ! AM Niveau de ref 2m
    522              ! AM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
    523              ! AM     .               /(zdu2*0.5*(zthvd+zthvu))
    524              rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5&
    525                   *(zthvd+zthvu))
    526 
    527 
    528              IF (rhino(i,k)>=ricr) THEN
    529                 pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))&
    530                      /(rhino(i,k-1)-rhino(i,k))
    531                 ! test04
    532                 pblh(i) = pblh(i) + 100.
    533                 pblt(i) = t(i, k-1) + (t(i,k)-t(i,k-1))*(pblh(i)-z(i,k-1))&
    534                      /(z(i,k)- z(i,k-1))
    535                 check(i) = .FALSE.
    536                 ! IM 170305 BEG
    537                 IF (1==0) THEN
    538                    ! debug print -120;34       -34-        58 et    0;26 wamp
    539                    IF (i==950 .OR. i==192 .OR. i==624 .OR. i==118) THEN
    540                       PRINT *, ' i,Th_th,Therm,qT :', i, th_th(i), therm(i), &
    541                            qt_th(i)
    542                       q_star = kqfs(i)/wm(i)
    543                       t_star = khfs(i)/wm(i)
    544                       PRINT *, 'q* t*, b1,b2,b212 ', q_star, t_star, &
    545                            b1*(1.+2.*retv*qt_th(i))*t_star**2, &
    546                            (retv*th_th(i))**2*b2*q_star**2, 2.*retv*th_th(i)&
    547                            *b212*q_star *t_star
    548                       PRINT *, 'zdu2 ,100.*ustar(i)**2', zdu2, fac*ustar(i)**2
    549                    END IF
    550                 END IF !(1.EQ.0) THEN
    551                 ! IM 170305 END
    552                 ! q_star = kqfs(i)/wm(i)
    553                 ! t_star = khfs(i)/wm(i)
    554                 ! trmb1(i) = b1*(1.+2.*RETV*q(i,1))*t_star**2
    555                 ! trmb2(i) = (RETV*T(i,1))**2*b2*q_star**2
    556                 ! Omega now   trmb3(i) = 2.*RETV*T(i,1)*b212*q_star*t_star
    557              END IF
     499      DO i = 1, knon
     500        IF (check(i)) THEN
     501          ! test     zdu2 =
     502          ! (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
     503          zdu2 = u(i, k)**2 + v(i, k)**2
     504          zdu2 = max(zdu2, 1.0E-20)
     505          ! Theta_v environnement
     506          zthvd = t(i, k) / s(i, k) * (1. + retv * q(i, k))
     507
     508          ! et therm Theta_v (avec hypothese de constance de H&B,
     509          ! zthvu=(t(i,1)+therm(i))/s(i,1)*(1.+RETV*q(i,1))
     510          zthvu = th_th(i) * (1. + retv * qt_th(i)) + therm(i)
     511
     512
     513          ! Le Ri par Theta_v
     514          ! AM Niveau de ref 2m
     515          ! AM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
     516          ! AM     .               /(zdu2*0.5*(zthvd+zthvu))
     517          rhino(i, k) = (z(i, k) - zref) * rg * (zthvd - zthvu) / (zdu2 * 0.5&
     518                  * (zthvd + zthvu))
     519
     520          IF (rhino(i, k)>=ricr) THEN
     521            pblh(i) = z(i, k - 1) + (z(i, k - 1) - z(i, k)) * (ricr - rhino(i, k - 1))&
     522                    / (rhino(i, k - 1) - rhino(i, k))
     523            ! test04
     524            pblh(i) = pblh(i) + 100.
     525            pblt(i) = t(i, k - 1) + (t(i, k) - t(i, k - 1)) * (pblh(i) - z(i, k - 1))&
     526                    / (z(i, k) - z(i, k - 1))
     527            check(i) = .FALSE.
     528            ! IM 170305 BEG
     529            IF (1==0) THEN
     530              ! debug print -120;34       -34-        58 et    0;26 wamp
     531              IF (i==950 .OR. i==192 .OR. i==624 .OR. i==118) THEN
     532                PRINT *, ' i,Th_th,Therm,qT :', i, th_th(i), therm(i), &
     533                        qt_th(i)
     534                q_star = kqfs(i) / wm(i)
     535                t_star = khfs(i) / wm(i)
     536                PRINT *, 'q* t*, b1,b2,b212 ', q_star, t_star, &
     537                        b1 * (1. + 2. * retv * qt_th(i)) * t_star**2, &
     538                        (retv * th_th(i))**2 * b2 * q_star**2, 2. * retv * th_th(i)&
     539                        * b212 * q_star * t_star
     540                PRINT *, 'zdu2 ,100.*ustar(i)**2', zdu2, fac * ustar(i)**2
     541              END IF
     542            END IF !(1.EQ.0) THEN
     543            ! IM 170305 END
     544            ! q_star = kqfs(i)/wm(i)
     545            ! t_star = khfs(i)/wm(i)
     546            ! trmb1(i) = b1*(1.+2.*RETV*q(i,1))*t_star**2
     547            ! trmb2(i) = (RETV*T(i,1))**2*b2*q_star**2
     548            ! Omega now   trmb3(i) = 2.*RETV*T(i,1)*b212*q_star*t_star
    558549          END IF
    559        END DO
     550        END IF
     551      END DO
    560552    END DO
    561553
    … …  
    564556
    565557    DO i = 1, knon
    566        IF (check(i)) pblh(i) = z(i, isommet)
     558      IF (check(i)) pblh(i) = z(i, isommet)
    567559    END DO
    568560
    … …  
    579571
    580572    DO i = 1, knon
    581        pblmin = 700.0*ustar(i)
    582        pblh(i) = max(pblh(i), pblmin)
    583        ! par exemple :
    584        pblt(i) = t(i, 2) + (t(i,3)-t(i,2))*(pblh(i)-z(i,2))/(z(i,3)-z(i,2))
     573      pblmin = 700.0 * ustar(i)
     574      pblh(i) = max(pblh(i), pblmin)
     575      ! par exemple :
     576      pblt(i) = t(i, 2) + (t(i, 3) - t(i, 2)) * (pblh(i) - z(i, 2)) / (z(i, 3) - z(i, 2))
    585577    END DO
    586578
    … …  
    589581    ! ********************************************************************
    590582    DO i = 1, knon
    591        check(i) = .TRUE.
    592        zsat(i) = .FALSE.
    593        ! omegafl utilise pour prolongement CAPE
    594        omegafl(i) = .FALSE.
    595        cape(i) = 0.
    596        kape(i) = 0.
    597        eauliq(i) = 0.
    598        ctei(i) = 0.
    599        pblk(i) = 0.0
    600        fak1(i) = ustar(i)*pblh(i)*vk
    601 
    602        ! Do additional preparation for unstable cases only, set temperature
    603        ! and moisture perturbations depending on stability.
    604        ! *** Rq: les formule sont prises dans leur forme CS ***
    605        IF (unstbl(i)) THEN
    606           ! AM Niveau de ref du thermique
    607           ! AM          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
    608           ! AM     .         *(1.+RETV*q(i,1))
    609           zxt = (th_th(i)-zref*0.5*rg/rcpd/(1.+rvtmp2*qt_th(i)))* &
    610                (1.+retv*qt_th(i))
    611           phiminv(i) = (1.-binm*pblh(i)*unsobklen(i))**onet
    612           phihinv(i) = sqrt(1.-binh*pblh(i)*unsobklen(i))
    613           wm(i) = ustar(i)*phiminv(i)
    614           fak2(i) = wm(i)*pblh(i)*vk
    615           wstar(i) = (heatv(i)*rg*pblh(i)/zxt)**onet
    616           fak3(i) = fakn*wstar(i)/wm(i)
    617        ELSE
    618           wstar(i) = 0.
    619        END IF
    620        ! Computes Theta_e for thermal (all cases : to be modified)
    621        ! attention ajout therm(i) = virtuelle
    622        the_th(i) = th_th(i) + therm(i) + rlvcp*qt_th(i)
    623        ! ou:    The_th(i) = Th_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
     583      check(i) = .TRUE.
     584      zsat(i) = .FALSE.
     585      ! omegafl utilise pour prolongement CAPE
     586      omegafl(i) = .FALSE.
     587      cape(i) = 0.
     588      kape(i) = 0.
     589      eauliq(i) = 0.
     590      ctei(i) = 0.
     591      pblk(i) = 0.0
     592      fak1(i) = ustar(i) * pblh(i) * vk
     593
     594      ! Do additional preparation for unstable cases only, set temperature
     595      ! and moisture perturbations depending on stability.
     596      ! *** Rq: les formule sont prises dans leur forme CS ***
     597      IF (unstbl(i)) THEN
     598        ! AM Niveau de ref du thermique
     599        ! AM          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
     600        ! AM     .         *(1.+RETV*q(i,1))
     601        zxt = (th_th(i) - zref * 0.5 * rg / rcpd / (1. + rvtmp2 * qt_th(i))) * &
     602                (1. + retv * qt_th(i))
     603        phiminv(i) = (1. - binm * pblh(i) * unsobklen(i))**onet
     604        phihinv(i) = sqrt(1. - binh * pblh(i) * unsobklen(i))
     605        wm(i) = ustar(i) * phiminv(i)
     606        fak2(i) = wm(i) * pblh(i) * vk
     607        wstar(i) = (heatv(i) * rg * pblh(i) / zxt)**onet
     608        fak3(i) = fakn * wstar(i) / wm(i)
     609      ELSE
     610        wstar(i) = 0.
     611      END IF
     612      ! Computes Theta_e for thermal (all cases : to be modified)
     613      ! attention ajout therm(i) = virtuelle
     614      the_th(i) = th_th(i) + therm(i) + rlvcp * qt_th(i)
     615      ! ou:    The_th(i) = Th_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
    624616    END DO
    625617
    … …  
    629621    DO k = 2, isommet
    630622
    631        ! Find levels within boundary layer:
    632 
    633        DO i = 1, knon
    634           unslev(i) = .FALSE.
    635           stblev(i) = .FALSE.
    636           zm(i) = z(i, k-1)
    637           zp(i) = z(i, k)
    638           IF (zkmin==0.0 .AND. zp(i)>pblh(i)) zp(i) = pblh(i)
    639           IF (zm(i)<pblh(i)) THEN
    640              zmzp = 0.5*(zm(i)+zp(i))
    641              ! debug
    642              ! if (i.EQ.1864) THEN
    643              ! PRINT*,'i,pblh(1864),obklen(1864)',i,pblh(i),obklen(i)
    644              ! END IF
    645 
    646              zh(i) = zmzp/pblh(i)
    647              zl(i) = zmzp*unsobklen(i)
    648              zzh(i) = 0.
    649              IF (zh(i)<=1.0) zzh(i) = (1.-zh(i))**2
    650 
    651              ! stblev for points zm < plbh and stable and neutral
    652              ! unslev for points zm < plbh and unstable
    653 
    654              IF (unstbl(i)) THEN
    655                 unslev(i) = .TRUE.
    656              ELSE
    657                 stblev(i) = .TRUE.
    658              END IF
     623      ! Find levels within boundary layer:
     624
     625      DO i = 1, knon
     626        unslev(i) = .FALSE.
     627        stblev(i) = .FALSE.
     628        zm(i) = z(i, k - 1)
     629        zp(i) = z(i, k)
     630        IF (zkmin==0.0 .AND. zp(i)>pblh(i)) zp(i) = pblh(i)
     631        IF (zm(i)<pblh(i)) THEN
     632          zmzp = 0.5 * (zm(i) + zp(i))
     633          ! debug
     634          ! if (i.EQ.1864) THEN
     635          ! PRINT*,'i,pblh(1864),obklen(1864)',i,pblh(i),obklen(i)
     636          ! END IF
     637
     638          zh(i) = zmzp / pblh(i)
     639          zl(i) = zmzp * unsobklen(i)
     640          zzh(i) = 0.
     641          IF (zh(i)<=1.0) zzh(i) = (1. - zh(i))**2
     642
     643          ! stblev for points zm < plbh and stable and neutral
     644          ! unslev for points zm < plbh and unstable
     645
     646          IF (unstbl(i)) THEN
     647            unslev(i) = .TRUE.
     648          ELSE
     649            stblev(i) = .TRUE.
    659650          END IF
    660        END DO
    661        ! PRINT*,'fin calcul niveaux'
    662 
    663        ! Stable and neutral points; set diffusivities; counter-gradient
    664        ! terms zero for stable case:
    665 
    666        DO i = 1, knon
    667           IF (stblev(i)) THEN
    668              IF (zl(i)<=1.) THEN
    669                 pblk(i) = fak1(i)*zh(i)*zzh(i)/(1.+betas*zl(i))
    670              ELSE
    671                 pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas+zl(i))
    672              END IF
    673              ! pcfm(i,k) = pblk(i)
    674              ! pcfh(i,k) = pcfm(i,k)
     651        END IF
     652      END DO
     653      ! PRINT*,'fin calcul niveaux'
     654
     655      ! Stable and neutral points; set diffusivities; counter-gradient
     656      ! terms zero for stable case:
     657
     658      DO i = 1, knon
     659        IF (stblev(i)) THEN
     660          IF (zl(i)<=1.) THEN
     661            pblk(i) = fak1(i) * zh(i) * zzh(i) / (1. + betas * zl(i))
     662          ELSE
     663            pblk(i) = fak1(i) * zh(i) * zzh(i) / (betas + zl(i))
    675664          END IF
    676        END DO
    677 
    678        ! unssrf, unstable within surface layer of pbl
    679        ! unsout, unstable within outer   layer of pbl
    680 
    681        DO i = 1, knon
    682           unssrf(i) = .FALSE.
    683           unsout(i) = .FALSE.
    684           IF (unslev(i)) THEN
    685              IF (zh(i)<sffrac) THEN
    686                 unssrf(i) = .TRUE.
    687              ELSE
    688                 unsout(i) = .TRUE.
    689              END IF
     665          ! pcfm(i,k) = pblk(i)
     666          ! pcfh(i,k) = pcfm(i,k)
     667        END IF
     668      END DO
     669
     670      ! unssrf, unstable within surface layer of pbl
     671      ! unsout, unstable within outer   layer of pbl
     672
     673      DO i = 1, knon
     674        unssrf(i) = .FALSE.
     675        unsout(i) = .FALSE.
     676        IF (unslev(i)) THEN
     677          IF (zh(i)<sffrac) THEN
     678            unssrf(i) = .TRUE.
     679          ELSE
     680            unsout(i) = .TRUE.
    690681          END IF
    691        END DO
    692 
    693        ! Unstable for surface layer; counter-gradient terms zero
    694 
    695        DO i = 1, knon
    696           IF (unssrf(i)) THEN
    697              term = (1.-betam*zl(i))**onet
    698              pblk(i) = fak1(i)*zh(i)*zzh(i)*term
    699              pr(i) = term/sqrt(1.-betah*zl(i))
     682        END IF
     683      END DO
     684
     685      ! Unstable for surface layer; counter-gradient terms zero
     686
     687      DO i = 1, knon
     688        IF (unssrf(i)) THEN
     689          term = (1. - betam * zl(i))**onet
     690          pblk(i) = fak1(i) * zh(i) * zzh(i) * term
     691          pr(i) = term / sqrt(1. - betah * zl(i))
     692        END IF
     693      END DO
     694      ! PRINT*,'fin counter-gradient terms zero'
     695
     696      ! Unstable for outer layer; counter-gradient terms non-zero:
     697
     698      DO i = 1, knon
     699        IF (unsout(i)) THEN
     700          pblk(i) = fak2(i) * zh(i) * zzh(i)
     701          ! cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
     702          ! cgh(i,k) = khfs(i)*cgs(i,k)
     703          pr(i) = phiminv(i) / phihinv(i) + ccon * fak3(i) / fak
     704          ! cgq(i,k) = kqfs(i)*cgs(i,k)
     705        END IF
     706      END DO
     707      ! PRINT*,'fin counter-gradient terms non zero'
     708
     709      ! For all unstable layers, compute diffusivities and ctrgrad ter m
     710
     711      ! DO i = 1, knon
     712      ! IF (unslev(i)) THEN
     713      ! pcfm(i,k) = pblk(i)
     714      ! pcfh(i,k) = pblk(i)/pr(i)
     715      ! etc cf original
     716      ! ENDIF
     717      ! ENDDO
     718
     719      ! For all layers, compute integral info and CTEI
     720
     721      DO i = 1, knon
     722        IF (check(i) .OR. omegafl(i)) THEN
     723          IF (.NOT. zsat(i)) THEN
     724            ! Th2 = The_th(i) - RLvCp*qT_th(i)
     725            th2 = th_th(i)
     726            t2 = th2 * s(i, k)
     727            ! thermodyn functions
     728            zdelta = max(0., sign(1., rtt - t2))
     729            qqsat = r2es * foeew(t2, zdelta) / pplay(i, k)
     730            qqsat = min(0.5, qqsat)
     731            zcor = 1. / (1. - retv * qqsat)
     732            qqsat = qqsat * zcor
     733
     734            IF (qqsat<qt_th(i)) THEN
     735              ! on calcule lcl
     736              IF (k==2) THEN
     737                plcl(i) = z(i, k)
     738              ELSE
     739                plcl(i) = z(i, k - 1) + (z(i, k - 1) - z(i, k)) * (qt_th(i)&
     740                        - qsatbef(i)) / (qsatbef(i) - qqsat)
     741              END IF
     742              zsat(i) = .TRUE.
     743              tbef(i) = t2
     744            END IF
     745
     746            qsatbef(i) = qqsat ! bug dans la version orig ???
    700747          END IF
    701        END DO
    702        ! PRINT*,'fin counter-gradient terms zero'
    703 
    704        ! Unstable for outer layer; counter-gradient terms non-zero:
    705 
    706        DO i = 1, knon
    707           IF (unsout(i)) THEN
    708              pblk(i) = fak2(i)*zh(i)*zzh(i)
    709              ! cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
    710              ! cgh(i,k) = khfs(i)*cgs(i,k)
    711              pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
    712              ! cgq(i,k) = kqfs(i)*cgs(i,k)
    713           END IF
    714        END DO
    715        ! PRINT*,'fin counter-gradient terms non zero'
    716 
    717        ! For all unstable layers, compute diffusivities and ctrgrad ter m
    718 
    719        ! DO i = 1, knon
    720        ! IF (unslev(i)) THEN
    721        ! pcfm(i,k) = pblk(i)
    722        ! pcfh(i,k) = pblk(i)/pr(i)
    723        ! etc cf original
    724        ! ENDIF
    725        ! ENDDO
    726 
    727        ! For all layers, compute integral info and CTEI
    728 
    729        DO i = 1, knon
    730           IF (check(i) .OR. omegafl(i)) THEN
    731              IF (.NOT. zsat(i)) THEN
    732                 ! Th2 = The_th(i) - RLvCp*qT_th(i)
    733                 th2 = th_th(i)
    734                 t2 = th2*s(i, k)
    735                 ! thermodyn functions
    736                 zdelta = max(0., sign(1.,rtt-t2))
    737                 qqsat = r2es*foeew(t2, zdelta)/pplay(i, k)
    738                 qqsat = min(0.5, qqsat)
    739                 zcor = 1./(1.-retv*qqsat)
    740                 qqsat = qqsat*zcor
    741 
    742                 IF (qqsat<qt_th(i)) THEN
    743                    ! on calcule lcl
    744                    IF (k==2) THEN
    745                       plcl(i) = z(i, k)
    746                    ELSE
    747                       plcl(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(qt_th(i)&
    748                            -qsatbef(i))/(qsatbef(i)-qqsat)
    749                    END IF
    750                    zsat(i) = .TRUE.
    751                    tbef(i) = t2
    752                 END IF
    753 
    754                 qsatbef(i) = qqsat ! bug dans la version orig ???
    755              END IF
    756              ! amn ???? cette ligne a deja ete faite normalement ?
    757           END IF
    758           ! PRINT*,'hbtm2 i,k=',i,k
    759        END DO
     748          ! amn ???? cette ligne a deja ete faite normalement ?
     749        END IF
     750        ! PRINT*,'hbtm2 i,k=',i,k
     751      END DO
    760752    END DO ! end of level loop
    761753    ! IM 170305 BEG
    762754    IF (1==0) THEN
    763        PRINT *, 'hbtm2  ok'
     755      PRINT *, 'hbtm2  ok'
    764756    END IF !(1.EQ.0) THEN
    765757    ! IM 170305 END

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

    r5116 r5143  
    1414
    1515  USE dimphy
     16  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     17          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     18
    1619  IMPLICIT NONE
    1720
    18   include "YOEGWD.h"
    1921  include "YOMCST.h"
    2022

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

    r5137 r5143  
    11MODULE ice_sursat_mod
    22
    3 IMPLICIT NONE
    4 
    5 !--flight inventories
    6 
    7 REAL, SAVE, ALLOCATABLE :: flight_m(:,:)    !--flown distance m s-1 per cell
    8 !$OMP THREADPRIVATE(flight_m)
    9 REAL, SAVE, ALLOCATABLE :: flight_h2o(:,:)  !--emitted kg H2O s-1 per cell
    10 !$OMP THREADPRIVATE(flight_h2o)
    11 
    12 !--Fixed Parameters
    13 
    14 !--safety parameters for ERF function
    15 REAL, PARAMETER :: erf_lim = 5., eps = 1.e-10
    16 
    17 !--Tuning parameters (and their default values)
    18 
    19 !--chi gère la répartition statistique de la longueur des frontières
    20 !  entre les zones nuages et ISSR/ciel clair sous-saturé. Gamme de valeur :
    21 !  chi > 1, je n'ai pas regardé de limite max (pour chi = 1, la longueur de
    22 !  la frontière entre ne nuage et l'ISSR est proportionnelle à la
    23 !  répartition ISSR/ciel clair sous-sat dans la maille, i.e. il n'y a pas
    24 !  de favorisation de la localisation de l'ISSR près de nuage. Pour chi = inf,
    25 !  le nuage n'est en contact qu'avec de l'ISSR, quelle que soit la taille
    26 !  de l'ISSR dans la maille.)
    27 
    28 !--l_turb est la longueur de mélange pour la turbulence.
    29 !  dans les tests, ça n'a jamais été modifié pour l'instant.
    30 
    31 !--tun_N est le paramètre qui contrôle l'importance relative de N_2 par rapport à N_1.
    32 !  La valeur est comprise entre 1 et 2 (tun_N = 1 => N_1 = N_2)
    33 
    34 !--tun_ratqs : paramètre qui modifie ratqs en fonction de la valeur de
    35 !  alpha_cld selon la formule ratqs_new = ratqs_old / ( 1 + tun_ratqs *
    36 !  alpha_cld ). Dans le rapport il est appelé beta. Il varie entre 0 et 5
    37 !  (tun_ratqs = 0 => pas de modification de ratqs).
    38 
    39 !--gamma0 and Tgamma: define RHcrit limit above which heterogeneous freezing occurs as a function of T
    40 !--Karcher and Lohmann (2002)
    41 !--gamma = 2.583 - t / 207.83
    42 !--Ren and MacKenzie (2005) reused by Kärcher
    43 !--gamma = 2.349 - t / 259.0
    44 
    45 !--N_cld: number of clouds in cell (needs to be parametrized at some point)
    46 
    47 !--contrail cross section: typical value found in Freudenthaler et al, GRL, 22, 3501-3504, 1995
    48 !--in m2, 1000x200 = 200 000 m2 after 15 min
    49 
    50 REAL, SAVE :: chi=1.1, l_turb=50.0, tun_N=1.3, tun_ratqs=3.0
    51 REAL, SAVE :: gamma0=2.349, Tgamma=259.0, N_cld=100, contrail_cross_section=200000.0
    52 !$OMP THREADPRIVATE(chi,l_turb,tun_N,tun_ratqs,gamma0,Tgamma,N_cld,contrail_cross_section)
     3  IMPLICIT NONE
     4
     5  !--flight inventories
     6
     7  REAL, SAVE, ALLOCATABLE :: flight_m(:, :)    !--flown distance m s-1 per cell
     8  !$OMP THREADPRIVATE(flight_m)
     9  REAL, SAVE, ALLOCATABLE :: flight_h2o(:, :)  !--emitted kg H2O s-1 per cell
     10  !$OMP THREADPRIVATE(flight_h2o)
     11
     12  !--Fixed Parameters
     13
     14  !--safety parameters for ERF function
     15  REAL, PARAMETER :: erf_lim = 5., eps = 1.e-10
     16
     17  !--Tuning parameters (and their default values)
     18
     19  !--chi gère la répartition statistique de la longueur des frontières
     20  !  entre les zones nuages et ISSR/ciel clair sous-saturé. Gamme de valeur :
     21  !  chi > 1, je n'ai pas regardé de limite max (pour chi = 1, la longueur de
     22  !  la frontière entre ne nuage et l'ISSR est proportionnelle à la
     23  !  répartition ISSR/ciel clair sous-sat dans la maille, i.e. il n'y a pas
     24  !  de favorisation de la localisation de l'ISSR près de nuage. Pour chi = inf,
     25  !  le nuage n'est en contact qu'avec de l'ISSR, quelle que soit la taille
     26  !  de l'ISSR dans la maille.)
     27
     28  !--l_turb est la longueur de mélange pour la turbulence.
     29  !  dans les tests, ça n'a jamais été modifié pour l'instant.
     30
     31  !--tun_N est le paramètre qui contrôle l'importance relative de N_2 par rapport à N_1.
     32  !  La valeur est comprise entre 1 et 2 (tun_N = 1 => N_1 = N_2)
     33
     34  !--tun_ratqs : paramètre qui modifie ratqs en fonction de la valeur de
     35  !  alpha_cld selon la formule ratqs_new = ratqs_old / ( 1 + tun_ratqs *
     36  !  alpha_cld ). Dans le rapport il est appelé beta. Il varie entre 0 et 5
     37  !  (tun_ratqs = 0 => pas de modification de ratqs).
     38
     39  !--gamma0 and Tgamma: define RHcrit limit above which heterogeneous freezing occurs as a function of T
     40  !--Karcher and Lohmann (2002)
     41  !--gamma = 2.583 - t / 207.83
     42  !--Ren and MacKenzie (2005) reused by Kärcher
     43  !--gamma = 2.349 - t / 259.0
     44
     45  !--N_cld: number of clouds in cell (needs to be parametrized at some point)
     46
     47  !--contrail cross section: typical value found in Freudenthaler et al, GRL, 22, 3501-3504, 1995
     48  !--in m2, 1000x200 = 200 000 m2 after 15 min
     49
     50  REAL, SAVE :: chi = 1.1, l_turb = 50.0, tun_N = 1.3, tun_ratqs = 3.0
     51  REAL, SAVE :: gamma0 = 2.349, Tgamma = 259.0, N_cld = 100, contrail_cross_section = 200000.0
     52  !$OMP THREADPRIVATE(chi,l_turb,tun_N,tun_ratqs,gamma0,Tgamma,N_cld,contrail_cross_section)
    5353
    5454CONTAINS
    5555
    56 !*******************************************************************
    57 
    58 SUBROUTINE ice_sursat_init()
    59 
    60   USE lmdz_print_control, ONLY: lunout
    61   USE lmdz_ioipsl_getin_p, ONLY: getin_p
    62 
    63   IMPLICIT NONE
    64 
    65   CALL getin_p('flag_chi',chi)
    66   CALL getin_p('flag_l_turb',l_turb)
    67   CALL getin_p('flag_tun_N',tun_N)
    68   CALL getin_p('flag_tun_ratqs',tun_ratqs)
    69   CALL getin_p('gamma0',gamma0)
    70   CALL getin_p('Tgamma',Tgamma)
    71   CALL getin_p('N_cld',N_cld)
    72   CALL getin_p('contrail_cross_section',contrail_cross_section)
    73 
    74   WRITE(lunout,*) 'Parameters for ice_sursat param'
    75   WRITE(lunout,*) 'flag_chi = ', chi
    76   WRITE(lunout,*) 'flag_l_turb = ', l_turb
    77   WRITE(lunout,*) 'flag_tun_N = ', tun_N
    78   WRITE(lunout,*) 'flag_tun_ratqs = ', tun_ratqs
    79   WRITE(lunout,*) 'gamma0 = ', gamma0
    80   WRITE(lunout,*) 'Tgamma = ', Tgamma
    81   WRITE(lunout,*) 'N_cld = ', N_cld
    82   WRITE(lunout,*) 'contrail_cross_section = ', contrail_cross_section
    83 
    84 END SUBROUTINE ice_sursat_init
    85 
    86 !*******************************************************************
    87 
    88 SUBROUTINE airplane(debut,pphis,pplay,paprs,t_seri)
    89 
    90   USE dimphy
    91   USE lmdz_grid_phy, ONLY: klon_glo
    92   USE lmdz_geometry, ONLY: cell_area
    93   USE phys_cal_mod, ONLY: mth_cur
    94   USE lmdz_phys_mpi_data, ONLY: is_mpi_root
    95   USE lmdz_phys_omp_data, ONLY: is_omp_root
    96   USE lmdz_phys_para, ONLY: scatter, bcast
    97   USE lmdz_print_control, ONLY: lunout
    98   USE netcdf, ONLY: nf90_get_var, nf90_inq_varid, nf90_inquire_dimension, nf90_inq_dimid, &
    99       nf90_open, nf90_noerr
    100   USE lmdz_abort_physic, ONLY: abort_physic
    101 
    102   IMPLICIT NONE
    103 
    104   INCLUDE "YOMCST.h"
    105 
    106   !--------------------------------------------------------
    107   !--input variables
    108   !--------------------------------------------------------
    109   LOGICAL, INTENT(IN) :: debut
    110   REAL, INTENT(IN)    :: pphis(klon), pplay(klon,klev), paprs(klon,klev+1), t_seri(klon,klev)
    111 
    112   !--------------------------------------------------------
    113   !     ... Local variables
    114   !--------------------------------------------------------
    115 
    116   CHARACTER (LEN=20) :: modname='airplane_mod'
    117   INTEGER :: i, k, kori, iret, varid, error, ncida, klona
    118   INTEGER,SAVE :: nleva, ntimea
    119 !$OMP THREADPRIVATE(nleva,ntimea)
    120   REAL, ALLOCATABLE :: pkm_airpl_glo(:,:,:)    !--km/s
    121   REAL, ALLOCATABLE :: ph2o_airpl_glo(:,:,:)   !--molec H2O/cm3/s
    122   REAL, ALLOCATABLE, SAVE :: zmida(:), zinta(:)
    123   REAL, ALLOCATABLE, SAVE :: pkm_airpl(:,:,:)
    124   REAL, ALLOCATABLE, SAVE :: ph2o_airpl(:,:,:)
    125 !$OMP THREADPRIVATE(pkm_airpl,ph2o_airpl,zmida,zinta)
    126   REAL :: zalt(klon,klev+1)
    127   REAL :: zrho, zdz(klon,klev), zfrac
    128 
    129   IF (debut) THEN
    130   !--------------------------------------------------------------------------------
    131   !       ... Open the file and read airplane emissions
    132   !--------------------------------------------------------------------------------
    133 
    134   IF (is_mpi_root .AND. is_omp_root) THEN
    135 
    136       iret = nf90_open('aircraft_phy.nc', 0, ncida)
    137       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to open aircraft_phy.nc file',1)
    138       ! ... Get lengths
    139       iret = nf90_inq_dimid(ncida, 'time', varid)
    140       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to get time dimid in aircraft_phy.nc file',1)
    141       iret = nf90_inquire_dimension(ncida, varid,len= ntimea)
    142       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to get time dimlen aircraft_phy.nc file',1)
    143       iret = nf90_inq_dimid(ncida, 'vector', varid)
    144       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to get vector dimid aircraft_phy.nc file',1)
    145       iret = nf90_inquire_dimension(ncida, varid,len= klona)
    146       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to get vector dimlen aircraft_phy.nc file',1)
    147       iret = nf90_inq_dimid(ncida, 'lev', varid)
    148       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to get lev dimid aircraft_phy.nc file',1)
    149       iret = nf90_inquire_dimension(ncida, varid,len= nleva)
    150       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to get lev dimlen aircraft_phy.nc file',1)
    151 
    152       IF ( klona /= klon_glo ) THEN
    153         WRITE(lunout,*) 'klona & klon_glo =', klona, klon_glo
    154         CALL abort_physic(modname,'problem klon in aircraft_phy.nc file',1)
    155       ENDIF
    156 
    157       IF ( ntimea /= 12 ) THEN
    158         WRITE(lunout,*) 'ntimea=', ntimea
    159         CALL abort_physic(modname,'problem ntime<>12 in aircraft_phy.nc file',1)
    160       ENDIF
    161 
    162       ALLOCATE(zmida(nleva), STAT=error)
    163       IF (error /= 0) CALL abort_physic(modname,'problem to allocate zmida',1)
    164       ALLOCATE(pkm_airpl_glo(klona,nleva,ntimea), STAT=error)
    165       IF (error /= 0) CALL abort_physic(modname,'problem to allocate pkm_airpl_glo',1)
    166       ALLOCATE(ph2o_airpl_glo(klona,nleva,ntimea), STAT=error)
    167       IF (error /= 0) CALL abort_physic(modname,'problem to allocate ph2o_airpl_glo',1)
    168 
    169       iret = nf90_inq_varid(ncida, 'lev', varid)
    170       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to get lev dimid aircraft_phy.nc file',1)
    171       iret = nf90_get_var(ncida, varid, zmida)
    172       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to read zmida file',1)
    173 
    174       iret = nf90_inq_varid(ncida, 'emi_co2_aircraft', varid)  !--CO2 as a proxy for m flown -
    175       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to get emi_distance dimid aircraft_phy.nc file',1)
    176       iret = nf90_get_var(ncida, varid, pkm_airpl_glo)
    177       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to read pkm_airpl file',1)
    178 
    179       iret = nf90_inq_varid(ncida, 'emi_h2o_aircraft', varid)
    180       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to get emi_h2o_aircraft dimid aircraft_phy.nc file',1)
    181       iret = nf90_get_var(ncida, varid, ph2o_airpl_glo)
    182       IF (iret /= nf90_noerr) CALL abort_physic(modname,'problem to read ph2o_airpl file',1)
    183 
    184      ENDIF    !--is_mpi_root and is_omp_root
    185 
    186      CALL bcast(nleva)
    187      CALL bcast(ntimea)
    188 
    189      IF (.NOT.ALLOCATED(zmida)) ALLOCATE(zmida(nleva), STAT=error)
    190      IF (.NOT.ALLOCATED(zinta)) ALLOCATE(zinta(nleva+1), STAT=error)
    191 
    192      ALLOCATE(pkm_airpl(klon,nleva,ntimea))
    193      ALLOCATE(ph2o_airpl(klon,nleva,ntimea))
    194 
    195      ALLOCATE(flight_m(klon,klev))
    196      ALLOCATE(flight_h2o(klon,klev))
    197 
    198      CALL bcast(zmida)
    199      zinta(1)=0.0                                   !--surface
    200      DO k=2, nleva
    201        zinta(k) = (zmida(k-1)+zmida(k))/2.0*1000.0  !--conversion from km to m
    202      ENDDO
    203      zinta(nleva+1)=zinta(nleva)+(zmida(nleva)-zmida(nleva-1))*1000.0 !--extrapolation for last interface
    204      !print *,'zinta=', zinta
    205 
    206      CALL scatter(pkm_airpl_glo,pkm_airpl)
    207      CALL scatter(ph2o_airpl_glo,ph2o_airpl)
    208 
    209 !$OMP MASTER
    210      IF (is_mpi_root .AND. is_omp_root) THEN
     56  !*******************************************************************
     57
     58  SUBROUTINE ice_sursat_init()
     59
     60    USE lmdz_print_control, ONLY: lunout
     61    USE lmdz_ioipsl_getin_p, ONLY: getin_p
     62
     63    IMPLICIT NONE
     64
     65    CALL getin_p('flag_chi', chi)
     66    CALL getin_p('flag_l_turb', l_turb)
     67    CALL getin_p('flag_tun_N', tun_N)
     68    CALL getin_p('flag_tun_ratqs', tun_ratqs)
     69    CALL getin_p('gamma0', gamma0)
     70    CALL getin_p('Tgamma', Tgamma)
     71    CALL getin_p('N_cld', N_cld)
     72    CALL getin_p('contrail_cross_section', contrail_cross_section)
     73
     74    WRITE(lunout, *) 'Parameters for ice_sursat param'
     75    WRITE(lunout, *) 'flag_chi = ', chi
     76    WRITE(lunout, *) 'flag_l_turb = ', l_turb
     77    WRITE(lunout, *) 'flag_tun_N = ', tun_N
     78    WRITE(lunout, *) 'flag_tun_ratqs = ', tun_ratqs
     79    WRITE(lunout, *) 'gamma0 = ', gamma0
     80    WRITE(lunout, *) 'Tgamma = ', Tgamma
     81    WRITE(lunout, *) 'N_cld = ', N_cld
     82    WRITE(lunout, *) 'contrail_cross_section = ', contrail_cross_section
     83
     84  END SUBROUTINE ice_sursat_init
     85
     86  !*******************************************************************
     87
     88  SUBROUTINE airplane(debut, pphis, pplay, paprs, t_seri)
     89
     90    USE dimphy
     91    USE lmdz_grid_phy, ONLY: klon_glo
     92    USE lmdz_geometry, ONLY: cell_area
     93    USE phys_cal_mod, ONLY: mth_cur
     94    USE lmdz_phys_mpi_data, ONLY: is_mpi_root
     95    USE lmdz_phys_omp_data, ONLY: is_omp_root
     96    USE lmdz_phys_para, ONLY: scatter, bcast
     97    USE lmdz_print_control, ONLY: lunout
     98    USE netcdf, ONLY: nf90_get_var, nf90_inq_varid, nf90_inquire_dimension, nf90_inq_dimid, &
     99            nf90_open, nf90_noerr
     100    USE lmdz_abort_physic, ONLY: abort_physic
     101
     102    IMPLICIT NONE
     103
     104    INCLUDE "YOMCST.h"
     105
     106    !--------------------------------------------------------
     107    !--input variables
     108    !--------------------------------------------------------
     109    LOGICAL, INTENT(IN) :: debut
     110    REAL, INTENT(IN) :: pphis(klon), pplay(klon, klev), paprs(klon, klev + 1), t_seri(klon, klev)
     111
     112    !--------------------------------------------------------
     113    !   ... Local variables
     114    !--------------------------------------------------------
     115
     116    CHARACTER (LEN = 20) :: modname = 'airplane_mod'
     117    INTEGER :: i, k, kori, iret, varid, error, ncida, klona
     118    INTEGER, SAVE :: nleva, ntimea
     119    !$OMP THREADPRIVATE(nleva,ntimea)
     120    REAL, ALLOCATABLE :: pkm_airpl_glo(:, :, :)    !--km/s
     121    REAL, ALLOCATABLE :: ph2o_airpl_glo(:, :, :)   !--molec H2O/cm3/s
     122    REAL, ALLOCATABLE, SAVE :: zmida(:), zinta(:)
     123    REAL, ALLOCATABLE, SAVE :: pkm_airpl(:, :, :)
     124    REAL, ALLOCATABLE, SAVE :: ph2o_airpl(:, :, :)
     125    !$OMP THREADPRIVATE(pkm_airpl,ph2o_airpl,zmida,zinta)
     126    REAL :: zalt(klon, klev + 1)
     127    REAL :: zrho, zdz(klon, klev), zfrac
     128
     129    IF (debut) THEN
     130      !--------------------------------------------------------------------------------
     131      !       ... Open the file and read airplane emissions
     132      !--------------------------------------------------------------------------------
     133
     134      IF (is_mpi_root .AND. is_omp_root) THEN
     135
     136        iret = nf90_open('aircraft_phy.nc', 0, ncida)
     137        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to open aircraft_phy.nc file', 1)
     138        ! ... Get lengths
     139        iret = nf90_inq_dimid(ncida, 'time', varid)
     140        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to get time dimid in aircraft_phy.nc file', 1)
     141        iret = nf90_inquire_dimension(ncida, varid, len = ntimea)
     142        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to get time dimlen aircraft_phy.nc file', 1)
     143        iret = nf90_inq_dimid(ncida, 'vector', varid)
     144        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to get vector dimid aircraft_phy.nc file', 1)
     145        iret = nf90_inquire_dimension(ncida, varid, len = klona)
     146        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to get vector dimlen aircraft_phy.nc file', 1)
     147        iret = nf90_inq_dimid(ncida, 'lev', varid)
     148        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to get lev dimid aircraft_phy.nc file', 1)
     149        iret = nf90_inquire_dimension(ncida, varid, len = nleva)
     150        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to get lev dimlen aircraft_phy.nc file', 1)
     151
     152        IF (klona /= klon_glo) THEN
     153          WRITE(lunout, *) 'klona & klon_glo =', klona, klon_glo
     154          CALL abort_physic(modname, 'problem klon in aircraft_phy.nc file', 1)
     155        ENDIF
     156
     157        IF (ntimea /= 12) THEN
     158          WRITE(lunout, *) 'ntimea=', ntimea
     159          CALL abort_physic(modname, 'problem ntime<>12 in aircraft_phy.nc file', 1)
     160        ENDIF
     161
     162        ALLOCATE(zmida(nleva), STAT = error)
     163        IF (error /= 0) CALL abort_physic(modname, 'problem to allocate zmida', 1)
     164        ALLOCATE(pkm_airpl_glo(klona, nleva, ntimea), STAT = error)
     165        IF (error /= 0) CALL abort_physic(modname, 'problem to allocate pkm_airpl_glo', 1)
     166        ALLOCATE(ph2o_airpl_glo(klona, nleva, ntimea), STAT = error)
     167        IF (error /= 0) CALL abort_physic(modname, 'problem to allocate ph2o_airpl_glo', 1)
     168
     169        iret = nf90_inq_varid(ncida, 'lev', varid)
     170        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to get lev dimid aircraft_phy.nc file', 1)
     171        iret = nf90_get_var(ncida, varid, zmida)
     172        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to read zmida file', 1)
     173
     174        iret = nf90_inq_varid(ncida, 'emi_co2_aircraft', varid)  !--CO2 as a proxy for m flown -
     175        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to get emi_distance dimid aircraft_phy.nc file', 1)
     176        iret = nf90_get_var(ncida, varid, pkm_airpl_glo)
     177        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to read pkm_airpl file', 1)
     178
     179        iret = nf90_inq_varid(ncida, 'emi_h2o_aircraft', varid)
     180        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to get emi_h2o_aircraft dimid aircraft_phy.nc file', 1)
     181        iret = nf90_get_var(ncida, varid, ph2o_airpl_glo)
     182        IF (iret /= nf90_noerr) CALL abort_physic(modname, 'problem to read ph2o_airpl file', 1)
     183
     184      ENDIF    !--is_mpi_root and is_omp_root
     185
     186      CALL bcast(nleva)
     187      CALL bcast(ntimea)
     188
     189      IF (.NOT.ALLOCATED(zmida)) ALLOCATE(zmida(nleva), STAT = error)
     190      IF (.NOT.ALLOCATED(zinta)) ALLOCATE(zinta(nleva + 1), STAT = error)
     191
     192      ALLOCATE(pkm_airpl(klon, nleva, ntimea))
     193      ALLOCATE(ph2o_airpl(klon, nleva, ntimea))
     194
     195      ALLOCATE(flight_m(klon, klev))
     196      ALLOCATE(flight_h2o(klon, klev))
     197
     198      CALL bcast(zmida)
     199      zinta(1) = 0.0                                   !--surface
     200      DO k = 2, nleva
     201        zinta(k) = (zmida(k - 1) + zmida(k)) / 2.0 * 1000.0  !--conversion from km to m
     202      ENDDO
     203      zinta(nleva + 1) = zinta(nleva) + (zmida(nleva) - zmida(nleva - 1)) * 1000.0 !--extrapolation for last interface
     204      !print *,'zinta=', zinta
     205
     206      CALL scatter(pkm_airpl_glo, pkm_airpl)
     207      CALL scatter(ph2o_airpl_glo, ph2o_airpl)
     208
     209      !$OMP MASTER
     210      IF (is_mpi_root .AND. is_omp_root) THEN
    211211        DEALLOCATE(pkm_airpl_glo)
    212212        DEALLOCATE(ph2o_airpl_glo)
    213      ENDIF   !--is_mpi_root
    214 !$OMP END MASTER
    215 
    216   ENDIF !--debut
    217 
    218 !--compute altitude of model level interfaces
    219 
    220   DO i = 1, klon
    221     zalt(i,1)=pphis(i)/RG         !--in m
    222   ENDDO
    223 
    224   DO k=1, klev
     213      ENDIF   !--is_mpi_root
     214      !$OMP END MASTER
     215
     216    ENDIF !--debut
     217
     218    !--compute altitude of model level interfaces
     219
    225220    DO i = 1, klon
    226       zrho=pplay(i,k)/t_seri(i,k)/RD
    227       zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho/RG
    228       zalt(i,k+1)=zalt(i,k)+zdz(i,k)   !--in m
     221      zalt(i, 1) = pphis(i) / RG         !--in m
    229222    ENDDO
    230   ENDDO
    231 
    232 !--vertical reprojection
    233 
    234   flight_m(:,:)=0.0
    235   flight_h2o(:,:)=0.0
    236 
    237   DO k=1, klev
    238     DO kori=1, nleva
    239       DO i=1, klon
    240         !--fraction of layer kori included in layer k
    241         zfrac=max(0.0,min(zalt(i,k+1),zinta(kori+1))-max(zalt(i,k),zinta(kori)))/(zinta(kori+1)-zinta(kori))
    242         !--reproject
    243         flight_m(i,k)=flight_m(i,k) + pkm_airpl(i,kori,mth_cur)*zfrac
    244         !--reproject
    245         flight_h2o(i,k)=flight_h2o(i,k) + ph2o_airpl(i,kori,mth_cur)*zfrac   
     223
     224    DO k = 1, klev
     225      DO i = 1, klon
     226        zrho = pplay(i, k) / t_seri(i, k) / RD
     227        zdz(i, k) = (paprs(i, k) - paprs(i, k + 1)) / zrho / RG
     228        zalt(i, k + 1) = zalt(i, k) + zdz(i, k)   !--in m
    246229      ENDDO
    247230    ENDDO
    248   ENDDO
    249 
    250   DO k=1, klev
    251     DO i=1, klon
    252       !--molec.cm-3.s-1 / (molec/mol) * kg CO2/mol * m2 * m * cm3/m3 / (kg CO2/m) => m s-1 per cell
    253       flight_m(i,k)=flight_m(i,k)/RNAVO*44.e-3*cell_area(i)*zdz(i,k)*1.e6/16.37e-3
    254       flight_m(i,k)=flight_m(i,k)*100.0  !--x100 to augment signal to noise
    255       !--molec.cm-3.s-1 / (molec/mol) * kg H2O/mol * m2 * m * cm3/m3 => kg H2O s-1 per cell
    256       flight_h2o(i,k)=flight_h2o(i,k)/RNAVO*18.e-3*cell_area(i)*zdz(i,k)*1.e6
     231
     232    !--vertical reprojection
     233
     234    flight_m(:, :) = 0.0
     235    flight_h2o(:, :) = 0.0
     236
     237    DO k = 1, klev
     238      DO kori = 1, nleva
     239        DO i = 1, klon
     240          !--fraction of layer kori included in layer k
     241          zfrac = max(0.0, min(zalt(i, k + 1), zinta(kori + 1)) - max(zalt(i, k), zinta(kori))) / (zinta(kori + 1) - zinta(kori))
     242          !--reproject
     243          flight_m(i, k) = flight_m(i, k) + pkm_airpl(i, kori, mth_cur) * zfrac
     244          !--reproject
     245          flight_h2o(i, k) = flight_h2o(i, k) + ph2o_airpl(i, kori, mth_cur) * zfrac
     246        ENDDO
     247      ENDDO
    257248    ENDDO
    258   ENDDO
    259 
    260 END SUBROUTINE airplane
    261 
    262 !********************************************************************
    263 ! simple routine to initialise flight_m and test a flight corridor
    264 !--Olivier Boucher - 2021
    265 
    266 SUBROUTINE flight_init()
    267   USE dimphy
    268   USE lmdz_geometry, ONLY: cell_area, latitude_deg, longitude_deg
    269   IMPLICIT NONE
    270   INTEGER :: i
    271 
    272   ALLOCATE(flight_m(klon,klev))
    273   ALLOCATE(flight_h2o(klon,klev))
    274 
    275   flight_m(:,:) = 0.0    !--initialisation
    276   flight_h2o(:,:) = 0.0  !--initialisation
    277 
    278   DO i=1, klon
    279    IF (latitude_deg(i)>=42.0.AND.latitude_deg(i)<=48.0) THEN
    280      flight_m(i,38) = 50000.0  !--5000 m of flight/second in grid cell x 10 scaling
    281    ENDIF
    282   ENDDO
    283  
    284 
    285 END SUBROUTINE flight_init
    286 
    287 !*******************************************************************
    288 !--Routine to deal with ice supersaturation
    289 !--Determines the respective fractions of unsaturated clear sky, ice supersaturated clear sky and cloudy sky
    290 !--Diagnoses regions prone for non-persistent and persistent contrail formation
    291 
    292 !--Audran Borella - 2021
    293 
    294 SUBROUTINE ice_sursat(pplay, dpaprs, dtime, i, k, t, q, gamma_ss, &
    295                       qsat, t_actuel, rneb_seri, ratqs, rneb, qincld,   &
    296                       rnebss, qss, Tcontr, qcontr, qcontr2, fcontrN, fcontrP)
    297 
    298   USE dimphy
    299   USE lmdz_print_control,    ONLY: prt_level, lunout
    300   USE phys_state_var_mod,   ONLY: pbl_tke, t_ancien
    301   USE phys_local_var_mod,   ONLY: N1_ss, N2_ss
    302   USE phys_local_var_mod,   ONLY: drneb_sub, drneb_con, drneb_tur, drneb_avi
    303 !!  USE phys_local_var_mod,   ONLY: Tcontr, qcontr, fcontrN, fcontrP
    304   USE indice_sol_mod,       ONLY: is_ave
    305   USE lmdz_geometry,         ONLY: cell_area
    306   USE lmdz_clesphys
    307 
    308   IMPLICIT NONE
    309   INCLUDE "YOMCST.h"
    310   INCLUDE "YOETHF.h"
    311   INCLUDE "FCTTRE.h"
    312 
    313   ! Input
    314   ! Beware: this routine works on a gridpoint!
    315 
    316   REAL,     INTENT(IN)    :: pplay     ! layer pressure (Pa)
    317   REAL,     INTENT(IN)    :: dpaprs    ! layer delta pressure (Pa)
    318   REAL,     INTENT(IN)    :: dtime     ! intervalle du temps (s)
    319   REAL,     INTENT(IN)    :: t         ! température advectée (K)
    320   REAL,     INTENT(IN)    :: qsat      ! vapeur de saturation
    321   REAL,     INTENT(IN)    :: t_actuel  ! temperature actuelle de la maille (K)
    322   REAL,     INTENT(IN)    :: rneb_seri ! fraction nuageuse en memoire
    323   INTEGER,  INTENT(IN)    :: i, k
    324 
    325   !  Input/output
    326 
    327   REAL,     INTENT(INOUT) :: q         ! vapeur de la maille (=zq)
    328   REAL,     INTENT(INOUT) :: ratqs     ! determine la largeur de distribution de vapeur
    329   REAL,     INTENT(INOUT) :: Tcontr, qcontr, qcontr2, fcontrN, fcontrP
    330 
    331   !  Output
    332 
    333   REAL,     INTENT(OUT)   :: gamma_ss  !
    334   REAL,     INTENT(OUT)   :: rneb      !  cloud fraction
    335   REAL,     INTENT(OUT)   :: qincld    !  in-cloud total water
    336   REAL,     INTENT(OUT)   :: rnebss    !  ISSR fraction
    337   REAL,     INTENT(OUT)   :: qss       !  in-ISSR total water
    338 
    339   ! Local
    340 
    341   REAL PI
    342   PARAMETER (PI=4.*ATAN(1.))
    343   REAL rnebclr, gamma_prec
    344   REAL qclr, qvc, qcld, qi
    345   REAL zrho, zdz, zrhodz
    346   REAL pdf_N, pdf_N1, pdf_N2
    347   REAL pdf_a, pdf_b
    348   REAL pdf_e1, pdf_e2, pdf_k
    349   REAL drnebss, drnebclr, dqss, dqclr, sum_rneb_rnebss, dqss_avi
    350   REAL V_cell !--volume of the cell
    351   REAL M_cell !--dry mass of the cell
    352   REAL tke, sig, L_tur, b_tur, q_eq
    353   REAL V_env, V_cld, V_ss, V_clr
    354   REAL zcor
    355 
    356   !--more local variables for diagnostics
    357   !--imported from YOMCST.h
    358   !--eps_w = 0.622 = ratio of molecular masses of water and dry air (kg H2O kg air -1)
    359   !--RCPD = 1004 J kg air−1 K−1 = the isobaric heat capacity of air
    360   !--values from Schumann, Meteorol Zeitschrift, 1996
    361   !--EiH2O = 1.25 / 2.24 / 8.94 kg H2O / kg fuel for kerosene / methane / dihydrogen
    362   !--Qheat = 43.  /  50. / 120. MJ / kg fuel for kerosene / methane / dihydrogen
    363   REAL, PARAMETER :: EiH2O=1.25  !--emission index of water vapour for kerosene (kg kg-1)
    364   REAL, PARAMETER :: Qheat=43.E6 !--specific combustion heat for kerosene (J kg-1)
    365   REAL, PARAMETER :: eta=0.3     !--average propulsion efficiency of the aircraft
    366   !--Gcontr is the slope of the mean phase trajectory in the turbulent exhaust field on an absolute
    367   !--temperature versus water vapor partial pressure diagram. G has the unit of Pa K−1. Rap et al JGR 2010.
    368   REAL :: Gcontr
    369   !--Tcontr = critical temperature for contrail formation (T_LM in Schumann 1996, Eq 31 in appendix 2)
    370   !--qsatliqcontr = e_L(T_LM) in Schumann 1996 but expressed in specific humidity (kg kg humid air-1)
    371   REAL :: qsatliqcontr
    372 
    373      ! Initialisations
    374      zrho = pplay / t / RD            !--dry density kg m-3
    375      zrhodz = dpaprs / RG             !--dry air mass kg m-2
    376      zdz = zrhodz / zrho              !--cell thickness m
    377      V_cell = zdz * cell_area(i)      !--cell volume m3
    378      M_cell = zrhodz * cell_area(i)   !--cell dry air mass kg
    379 
    380      ! Recuperation de la memoire sur la couverture nuageuse
    381      rneb = rneb_seri
    382 
    383      ! Ajout des émissions de H2O dues à l'aviation
    384      ! q is the specific humidity (kg/kg humid air) hence the complicated equation to update q
    385      ! qnew = ( m_humid_air * qold + dm_H2O ) / ( m_humid_air + dm_H2O ) 
    386      !      = ( m_dry_air * qold + dm_h2O * (1-qold) ) / (m_dry_air + dm_H2O * (1-qold) )
    387      ! The equation is derived by writing m_humid_air = m_dry_air + m_H2O = m_dry_air / (1-q)
    388      ! flight_h2O is in kg H2O / s / cell
    389 
    390      IF (ok_plane_h2o) THEN
    391        q = ( M_cell*q + flight_h2o(i,k)*dtime*(1.-q) ) / (M_cell + flight_h2o(i,k)*dtime*(1.-q) )
    392      ENDIF
    393 
    394      !--Estimating gamma
    395      gamma_ss = MAX(1.0, gamma0 - t_actuel/Tgamma)
    396      !gamma_prec = MAX(1.0, gamma0 - t_ancien(i,k)/Tgamma)      !--formulation initiale d Audran
    397      gamma_prec = MAX(1.0, gamma0 - t/Tgamma)                   !--autre formulation possible basée sur le T du pas de temps
    398 
    399      ! Initialisation de qvc : q_sat du pas de temps precedent
    400      !qvc = R2ES*FOEEW(t_ancien(i,k),1.)/pplay      !--formulation initiale d Audran
    401      qvc = R2ES*FOEEW(t,1.)/pplay                   !--autre formulation possible basée sur le T du pas de temps
    402      qvc = min(0.5,qvc)
    403      zcor = 1./(1.-RETV*qvc)
    404      qvc = qvc*zcor
    405 
    406      ! Modification de ratqs selon formule proposee : ksi_new = ksi_old/(1+beta*alpha_cld)
    407      ratqs = ratqs / (tun_ratqs*rneb_seri + 1.)
    408 
    409      ! Calcul de N
    410      pdf_k = -sqrt(log(1.+ratqs**2.))
    411      pdf_a = log(qvc/q)/(pdf_k*sqrt(2.))
    412      pdf_b = pdf_k/(2.*sqrt(2.))
    413      pdf_e1 = pdf_a+pdf_b
    414      IF (abs(pdf_e1)>=erf_lim) THEN
    415         pdf_e1 = sign(1.,pdf_e1)
    416         pdf_N = max(0.,sign(rneb,pdf_e1))
    417      ELSE
     249
     250    DO k = 1, klev
     251      DO i = 1, klon
     252        !--molec.cm-3.s-1 / (molec/mol) * kg CO2/mol * m2 * m * cm3/m3 / (kg CO2/m) => m s-1 per cell
     253        flight_m(i, k) = flight_m(i, k) / RNAVO * 44.e-3 * cell_area(i) * zdz(i, k) * 1.e6 / 16.37e-3
     254        flight_m(i, k) = flight_m(i, k) * 100.0  !--x100 to augment signal to noise
     255        !--molec.cm-3.s-1 / (molec/mol) * kg H2O/mol * m2 * m * cm3/m3 => kg H2O s-1 per cell
     256        flight_h2o(i, k) = flight_h2o(i, k) / RNAVO * 18.e-3 * cell_area(i) * zdz(i, k) * 1.e6
     257      ENDDO
     258    ENDDO
     259
     260  END SUBROUTINE airplane
     261
     262  !********************************************************************
     263  ! simple routine to initialise flight_m and test a flight corridor
     264  !--Olivier Boucher - 2021
     265
     266  SUBROUTINE flight_init()
     267    USE dimphy
     268    USE lmdz_geometry, ONLY: cell_area, latitude_deg, longitude_deg
     269    IMPLICIT NONE
     270    INTEGER :: i
     271
     272    ALLOCATE(flight_m(klon, klev))
     273    ALLOCATE(flight_h2o(klon, klev))
     274
     275    flight_m(:, :) = 0.0    !--initialisation
     276    flight_h2o(:, :) = 0.0  !--initialisation
     277
     278    DO i = 1, klon
     279      IF (latitude_deg(i)>=42.0.AND.latitude_deg(i)<=48.0) THEN
     280        flight_m(i, 38) = 50000.0  !--5000 m of flight/second in grid cell x 10 scaling
     281      ENDIF
     282    ENDDO
     283
     284  END SUBROUTINE flight_init
     285
     286  !*******************************************************************
     287  !--Routine to deal with ice supersaturation
     288  !--Determines the respective fractions of unsaturated clear sky, ice supersaturated clear sky and cloudy sky
     289  !--Diagnoses regions prone for non-persistent and persistent contrail formation
     290
     291  !--Audran Borella - 2021
     292
     293  SUBROUTINE ice_sursat(pplay, dpaprs, dtime, i, k, t, q, gamma_ss, &
     294          qsat, t_actuel, rneb_seri, ratqs, rneb, qincld, &
     295          rnebss, qss, Tcontr, qcontr, qcontr2, fcontrN, fcontrP)
     296
     297    USE dimphy
     298    USE lmdz_print_control, ONLY: prt_level, lunout
     299    USE phys_state_var_mod, ONLY: pbl_tke, t_ancien
     300    USE phys_local_var_mod, ONLY: N1_ss, N2_ss
     301    USE phys_local_var_mod, ONLY: drneb_sub, drneb_con, drneb_tur, drneb_avi
     302    !!  USE phys_local_var_mod,   ONLY: Tcontr, qcontr, fcontrN, fcontrP
     303    USE indice_sol_mod, ONLY: is_ave
     304    USE lmdz_geometry, ONLY: cell_area
     305    USE lmdz_clesphys
     306    USE lmdz_YOETHF
     307    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     308
     309    IMPLICIT NONE
     310    INCLUDE "YOMCST.h"
     311
     312    ! Input
     313    ! Beware: this routine works on a gridpoint!
     314
     315    REAL, INTENT(IN) :: pplay     ! layer pressure (Pa)
     316    REAL, INTENT(IN) :: dpaprs    ! layer delta pressure (Pa)
     317    REAL, INTENT(IN) :: dtime     ! intervalle du temps (s)
     318    REAL, INTENT(IN) :: t         ! température advectée (K)
     319    REAL, INTENT(IN) :: qsat      ! vapeur de saturation
     320    REAL, INTENT(IN) :: t_actuel  ! temperature actuelle de la maille (K)
     321    REAL, INTENT(IN) :: rneb_seri ! fraction nuageuse en memoire
     322    INTEGER, INTENT(IN) :: i, k
     323
     324    !  Input/output
     325
     326    REAL, INTENT(INOUT) :: q         ! vapeur de la maille (=zq)
     327    REAL, INTENT(INOUT) :: ratqs     ! determine la largeur de distribution de vapeur
     328    REAL, INTENT(INOUT) :: Tcontr, qcontr, qcontr2, fcontrN, fcontrP
     329
     330    !  Output
     331
     332    REAL, INTENT(OUT) :: gamma_ss  !
     333    REAL, INTENT(OUT) :: rneb      !  cloud fraction
     334    REAL, INTENT(OUT) :: qincld    !  in-cloud total water
     335    REAL, INTENT(OUT) :: rnebss    !  ISSR fraction
     336    REAL, INTENT(OUT) :: qss       !  in-ISSR total water
     337
     338    ! Local
     339
     340    REAL PI
     341    PARAMETER (PI = 4. * ATAN(1.))
     342    REAL rnebclr, gamma_prec
     343    REAL qclr, qvc, qcld, qi
     344    REAL zrho, zdz, zrhodz
     345    REAL pdf_N, pdf_N1, pdf_N2
     346    REAL pdf_a, pdf_b
     347    REAL pdf_e1, pdf_e2, pdf_k
     348    REAL drnebss, drnebclr, dqss, dqclr, sum_rneb_rnebss, dqss_avi
     349    REAL V_cell !--volume of the cell
     350    REAL M_cell !--dry mass of the cell
     351    REAL tke, sig, L_tur, b_tur, q_eq
     352    REAL V_env, V_cld, V_ss, V_clr
     353    REAL zcor
     354
     355    !--more local variables for diagnostics
     356    !--imported from YOMCST.h
     357    !--eps_w = 0.622 = ratio of molecular masses of water and dry air (kg H2O kg air -1)
     358    !--RCPD = 1004 J kg air−1 K−1 = the isobaric heat capacity of air
     359    !--values from Schumann, Meteorol Zeitschrift, 1996
     360    !--EiH2O = 1.25 / 2.24 / 8.94 kg H2O / kg fuel for kerosene / methane / dihydrogen
     361    !--Qheat = 43.  /  50. / 120. MJ / kg fuel for kerosene / methane / dihydrogen
     362    REAL, PARAMETER :: EiH2O = 1.25  !--emission index of water vapour for kerosene (kg kg-1)
     363    REAL, PARAMETER :: Qheat = 43.E6 !--specific combustion heat for kerosene (J kg-1)
     364    REAL, PARAMETER :: eta = 0.3     !--average propulsion efficiency of the aircraft
     365    !--Gcontr is the slope of the mean phase trajectory in the turbulent exhaust field on an absolute
     366    !--temperature versus water vapor partial pressure diagram. G has the unit of Pa K−1. Rap et al JGR 2010.
     367    REAL :: Gcontr
     368    !--Tcontr = critical temperature for contrail formation (T_LM in Schumann 1996, Eq 31 in appendix 2)
     369    !--qsatliqcontr = e_L(T_LM) in Schumann 1996 but expressed in specific humidity (kg kg humid air-1)
     370    REAL :: qsatliqcontr
     371
     372    ! Initialisations
     373    zrho = pplay / t / RD            !--dry density kg m-3
     374    zrhodz = dpaprs / RG             !--dry air mass kg m-2
     375    zdz = zrhodz / zrho              !--cell thickness m
     376    V_cell = zdz * cell_area(i)      !--cell volume m3
     377    M_cell = zrhodz * cell_area(i)   !--cell dry air mass kg
     378
     379    ! Recuperation de la memoire sur la couverture nuageuse
     380    rneb = rneb_seri
     381
     382    ! Ajout des émissions de H2O dues à l'aviation
     383    ! q is the specific humidity (kg/kg humid air) hence the complicated equation to update q
     384    ! qnew = ( m_humid_air * qold + dm_H2O ) / ( m_humid_air + dm_H2O )
     385    !      = ( m_dry_air * qold + dm_h2O * (1-qold) ) / (m_dry_air + dm_H2O * (1-qold) )
     386    ! The equation is derived by writing m_humid_air = m_dry_air + m_H2O = m_dry_air / (1-q)
     387    ! flight_h2O is in kg H2O / s / cell
     388
     389    IF (ok_plane_h2o) THEN
     390      q = (M_cell * q + flight_h2o(i, k) * dtime * (1. - q)) / (M_cell + flight_h2o(i, k) * dtime * (1. - q))
     391    ENDIF
     392
     393    !--Estimating gamma
     394    gamma_ss = MAX(1.0, gamma0 - t_actuel / Tgamma)
     395    !gamma_prec = MAX(1.0, gamma0 - t_ancien(i,k)/Tgamma)      !--formulation initiale d Audran
     396    gamma_prec = MAX(1.0, gamma0 - t / Tgamma)                   !--autre formulation possible basée sur le T du pas de temps
     397
     398    ! Initialisation de qvc : q_sat du pas de temps precedent
     399    !qvc = R2ES*FOEEW(t_ancien(i,k),1.)/pplay      !--formulation initiale d Audran
     400    qvc = R2ES * FOEEW(t, 1.) / pplay                   !--autre formulation possible basée sur le T du pas de temps
     401    qvc = min(0.5, qvc)
     402    zcor = 1. / (1. - RETV * qvc)
     403    qvc = qvc * zcor
     404
     405    ! Modification de ratqs selon formule proposee : ksi_new = ksi_old/(1+beta*alpha_cld)
     406    ratqs = ratqs / (tun_ratqs * rneb_seri + 1.)
     407
     408    ! Calcul de N
     409    pdf_k = -sqrt(log(1. + ratqs**2.))
     410    pdf_a = log(qvc / q) / (pdf_k * sqrt(2.))
     411    pdf_b = pdf_k / (2. * sqrt(2.))
     412    pdf_e1 = pdf_a + pdf_b
     413    IF (abs(pdf_e1)>=erf_lim) THEN
     414      pdf_e1 = sign(1., pdf_e1)
     415      pdf_N = max(0., sign(rneb, pdf_e1))
     416    ELSE
     417      pdf_e1 = erf(pdf_e1)
     418      pdf_e1 = 0.5 * (1. + pdf_e1)
     419      pdf_N = max(0., rneb / pdf_e1)
     420    ENDIF
     421
     422    ! On calcule ensuite N1 et N2. Il y a deux cas : N > 1 et N <= 1
     423    ! Cas 1 : N > 1. N'arrive en theorie jamais, c'est une barriere
     424    ! On perd la memoire sur la temperature (sur qvc) pour garder
     425    ! celle sur alpha_cld
     426    IF (pdf_N>1.) THEN
     427      ! On inverse alpha_cld = int_qvc^infty P(q) dq
     428      ! pour determiner qvc = f(alpha_cld)
     429      ! On approxime en serie entiere erf-1(x)
     430      qvc = 2. * rneb - 1.
     431      qvc = qvc + PI / 12. * qvc**3 + 7. * PI**2 / 480. * qvc**5 &
     432              + 127. * PI**3 / 40320. * qvc**7 + 4369. * PI**4 / 5806080. * qvc**9 &
     433              + 34807. * PI**5 / 182476800. * qvc**11
     434      qvc = sqrt(PI) / 2. * qvc
     435      qvc = (qvc - pdf_b) * pdf_k * sqrt(2.)
     436      qvc = q * exp(qvc)
     437
     438      ! On met a jour rneb avec la nouvelle valeur de qvc
     439      ! La maj est necessaire a cause de la serie entiere approximative
     440      pdf_a = log(qvc / q) / (pdf_k * sqrt(2.))
     441      pdf_e1 = pdf_a + pdf_b
     442      IF (abs(pdf_e1)>=erf_lim) THEN
     443        pdf_e1 = sign(1., pdf_e1)
     444      ELSE
    418445        pdf_e1 = erf(pdf_e1)
    419         pdf_e1 = 0.5*(1.+pdf_e1)
    420         pdf_N = max(0.,rneb/pdf_e1)
    421      ENDIF
    422 
    423      ! On calcule ensuite N1 et N2. Il y a deux cas : N > 1 et N <= 1
    424      ! Cas 1 : N > 1. N'arrive en theorie jamais, c'est une barriere
    425      ! On perd la memoire sur la temperature (sur qvc) pour garder
    426      ! celle sur alpha_cld
    427      IF (pdf_N>1.) THEN
    428         ! On inverse alpha_cld = int_qvc^infty P(q) dq
    429         ! pour determiner qvc = f(alpha_cld)
    430         ! On approxime en serie entiere erf-1(x)
    431         qvc = 2.*rneb-1.
    432         qvc = qvc + PI/12.*qvc**3 + 7.*PI**2/480.*qvc**5 &
    433              + 127.*PI**3/40320.*qvc**7 + 4369.*PI**4/5806080.*qvc**9 &
    434              + 34807.*PI**5/182476800.*qvc**11
    435         qvc = sqrt(PI)/2.*qvc
    436         qvc = (qvc-pdf_b)*pdf_k*sqrt(2.)
    437         qvc = q*exp(qvc)
    438 
    439         ! On met a jour rneb avec la nouvelle valeur de qvc
    440         ! La maj est necessaire a cause de la serie entiere approximative
    441         pdf_a = log(qvc/q)/(pdf_k*sqrt(2.))
    442         pdf_e1 = pdf_a+pdf_b
    443         IF (abs(pdf_e1)>=erf_lim) THEN
    444            pdf_e1 = sign(1.,pdf_e1)
     446      ENDIF
     447      pdf_e1 = 0.5 * (1. + pdf_e1)
     448      rneb = pdf_e1
     449
     450      ! Si N > 1, N1 et N2 = 1
     451      pdf_N1 = 1.
     452      pdf_N2 = 1.
     453
     454      ! Cas 2 : N <= 1
     455    ELSE
     456      ! D'abord on calcule N2 avec le tuning
     457      pdf_N2 = min(1., pdf_N * tun_N)
     458
     459      ! Puis N1 pour assurer la conservation de alpha_cld
     460      pdf_a = log(qvc * gamma_prec / q) / (pdf_k * sqrt(2.))
     461      pdf_e2 = pdf_a + pdf_b
     462      IF (abs(pdf_e2)>=erf_lim) THEN
     463        pdf_e2 = sign(1., pdf_e2)
     464      ELSE
     465        pdf_e2 = erf(pdf_e2)
     466      ENDIF
     467      pdf_e2 = 0.5 * (1. + pdf_e2) ! integrale sous P pour q > gamma qsat
     468
     469      IF (abs(pdf_e1 - pdf_e2)<eps) THEN
     470        pdf_N1 = pdf_N2
     471      ELSE
     472        pdf_N1 = (rneb - pdf_N2 * pdf_e2) / (pdf_e1 - pdf_e2)
     473      ENDIF
     474
     475      ! Barriere qui traite le cas gamma_prec = 1.
     476      IF (pdf_N1<=0.) THEN
     477        pdf_N1 = 0.
     478        IF (pdf_e2>eps) THEN
     479          pdf_N2 = rneb / pdf_e2
    445480        ELSE
    446            pdf_e1 = erf(pdf_e1)
     481          pdf_N2 = 0.
    447482        ENDIF
    448         pdf_e1 = 0.5*(1.+pdf_e1)
    449         rneb = pdf_e1
    450        
    451         ! Si N > 1, N1 et N2 = 1
    452         pdf_N1 = 1.
    453         pdf_N2 = 1.
    454        
    455      ! Cas 2 : N <= 1
    456      ELSE
    457         ! D'abord on calcule N2 avec le tuning
    458         pdf_N2 = min(1.,pdf_N*tun_N)
    459        
    460         ! Puis N1 pour assurer la conservation de alpha_cld
    461         pdf_a = log(qvc*gamma_prec/q)/(pdf_k*sqrt(2.))
    462         pdf_e2 = pdf_a+pdf_b
    463         IF (abs(pdf_e2)>=erf_lim) THEN
    464            pdf_e2 = sign(1.,pdf_e2)
    465         ELSE
    466            pdf_e2 = erf(pdf_e2)
     483      ENDIF
     484    ENDIF
     485
     486    ! Physique 1
     487    ! Sublimation
     488    IF (qvc<qsat) THEN
     489      pdf_a = log(qvc / q) / (pdf_k * sqrt(2.))
     490      pdf_e1 = pdf_a + pdf_b
     491      IF (abs(pdf_e1)>=erf_lim) THEN
     492        pdf_e1 = sign(1., pdf_e1)
     493      ELSE
     494        pdf_e1 = erf(pdf_e1)
     495      ENDIF
     496
     497      pdf_a = log(qsat / q) / (pdf_k * sqrt(2.))
     498      pdf_e2 = pdf_a + pdf_b
     499      IF (abs(pdf_e2)>=erf_lim) THEN
     500        pdf_e2 = sign(1., pdf_e2)
     501      ELSE
     502        pdf_e2 = erf(pdf_e2)
     503      ENDIF
     504
     505      pdf_e1 = 0.5 * pdf_N1 * (pdf_e1 - pdf_e2)
     506
     507      ! Calcul et ajout de la tendance
     508      drneb_sub(i, k) = - pdf_e1 / dtime    !--unit [s-1]
     509      rneb = rneb + drneb_sub(i, k) * dtime
     510    ELSE
     511      drneb_sub(i, k) = 0.
     512    ENDIF
     513
     514    ! NOTE : verifier si ca marche bien pour gamma proche de 1.
     515
     516    ! Condensation
     517    IF (gamma_ss * qsat<gamma_prec * qvc) THEN
     518
     519      pdf_a = log(gamma_ss * qsat / q) / (pdf_k * sqrt(2.))
     520      pdf_e1 = pdf_a + pdf_b
     521      IF (abs(pdf_e1)>=erf_lim) THEN
     522        pdf_e1 = sign(1., pdf_e1)
     523      ELSE
     524        pdf_e1 = erf(pdf_e1)
     525      ENDIF
     526
     527      pdf_a = log(gamma_prec * qvc / q) / (pdf_k * sqrt(2.))
     528      pdf_e2 = pdf_a + pdf_b
     529      IF (abs(pdf_e2)>=erf_lim) THEN
     530        pdf_e2 = sign(1., pdf_e2)
     531      ELSE
     532        pdf_e2 = erf(pdf_e2)
     533      ENDIF
     534
     535      pdf_e1 = 0.5 * (1. - pdf_N1) * (pdf_e1 - pdf_e2)
     536      pdf_e2 = 0.5 * (1. - pdf_N2) * (1. + pdf_e2)
     537
     538      ! Calcul et ajout de la tendance
     539      drneb_con(i, k) = (pdf_e1 + pdf_e2) / dtime         !--unit [s-1]
     540      rneb = rneb + drneb_con(i, k) * dtime
     541
     542    ELSE
     543
     544      pdf_a = log(gamma_ss * qsat / q) / (pdf_k * sqrt(2.))
     545      pdf_e1 = pdf_a + pdf_b
     546      IF (abs(pdf_e1)>=erf_lim) THEN
     547        pdf_e1 = sign(1., pdf_e1)
     548      ELSE
     549        pdf_e1 = erf(pdf_e1)
     550      ENDIF
     551      pdf_e1 = 0.5 * (1. - pdf_N2) * (1. + pdf_e1)
     552
     553      ! Calcul et ajout de la tendance
     554      drneb_con(i, k) = pdf_e1 / dtime         !--unit [s-1]
     555      rneb = rneb + drneb_con(i, k) * dtime
     556
     557    ENDIF
     558
     559    ! Calcul des grandeurs diagnostiques
     560    ! Determination des grandeurs ciel clair
     561    pdf_a = log(qsat / q) / (pdf_k * sqrt(2.))
     562    pdf_e1 = pdf_a + pdf_b
     563    IF (abs(pdf_e1)>=erf_lim) THEN
     564      pdf_e1 = sign(1., pdf_e1)
     565    ELSE
     566      pdf_e1 = erf(pdf_e1)
     567    ENDIF
     568    pdf_e1 = 0.5 * (1. - pdf_e1)
     569
     570    pdf_e2 = pdf_a - pdf_b
     571    IF (abs(pdf_e2)>=erf_lim) THEN
     572      pdf_e2 = sign(1., pdf_e2)
     573    ELSE
     574      pdf_e2 = erf(pdf_e2)
     575    ENDIF
     576    pdf_e2 = 0.5 * q * (1. - pdf_e2)
     577
     578    rnebclr = pdf_e1
     579    qclr = pdf_e2
     580
     581    ! Determination de q_cld
     582    ! Partie 1
     583    pdf_a = log(max(qsat, qvc) / q) / (pdf_k * sqrt(2.))
     584    pdf_e1 = pdf_a - pdf_b
     585    IF (abs(pdf_e1)>=erf_lim) THEN
     586      pdf_e1 = sign(1., pdf_e1)
     587    ELSE
     588      pdf_e1 = erf(pdf_e1)
     589    ENDIF
     590
     591    pdf_a = log(min(gamma_ss * qsat, gamma_prec * qvc) / q) / (pdf_k * sqrt(2.))
     592    pdf_e2 = pdf_a - pdf_b
     593    IF (abs(pdf_e2)>=erf_lim) THEN
     594      pdf_e2 = sign(1., pdf_e2)
     595    ELSE
     596      pdf_e2 = erf(pdf_e2)
     597    ENDIF
     598
     599    pdf_e1 = 0.5 * q * pdf_N1 * (pdf_e1 - pdf_e2)
     600
     601    qcld = pdf_e1
     602
     603    ! Partie 2 (sous condition)
     604    IF (gamma_ss * qsat>gamma_prec * qvc) THEN
     605      pdf_a = log(gamma_ss * qsat / q) / (pdf_k * sqrt(2.))
     606      pdf_e1 = pdf_a - pdf_b
     607      IF (abs(pdf_e1)>=erf_lim) THEN
     608        pdf_e1 = sign(1., pdf_e1)
     609      ELSE
     610        pdf_e1 = erf(pdf_e1)
     611      ENDIF
     612
     613      pdf_e2 = 0.5 * q * pdf_N2 * (pdf_e2 - pdf_e1)
     614
     615      qcld = qcld + pdf_e2
     616
     617      pdf_e2 = pdf_e1
     618    ENDIF
     619
     620    ! Partie 3
     621    pdf_e2 = 0.5 * q * (1. + pdf_e2)
     622
     623    qcld = qcld + pdf_e2
     624
     625    ! Fin du calcul de q_cld
     626
     627    ! Determination des grandeurs ISSR via les equations de conservation
     628    rneb = MIN(rneb, 1. - rnebclr - eps)      !--ajout OB - barrière
     629    rnebss = MAX(0.0, 1. - rnebclr - rneb)  !--ajout OB
     630    qss = MAX(0.0, q - qclr - qcld)         !--ajout OB
     631
     632    ! Physique 2 : Turbulence
     633    IF (rneb>eps.AND.rneb<1. - eps) THEN ! rneb != 0 and != 1
     634
     635      tke = pbl_tke(i, k, is_ave)
     636      ! A MODIFIER formule a revoir
     637      L_tur = min(l_turb, sqrt(tke) * dtime)
     638
     639      ! On fait pour l'instant l'hypothese a = 3b. V = 4/3 pi a b**2 = alpha_cld
     640      ! donc b = alpha_cld/4pi **1/3.
     641      b_tur = (rneb * V_cell / 4. / PI / N_cld)**(1. / 3.)
     642      ! On verifie que la longeur de melange n'est pas trop grande
     643      IF (L_tur>b_tur) THEN
     644        L_tur = b_tur
     645      ENDIF
     646
     647      V_env = N_cld * 4. * PI * (3. * (b_tur**2.) * L_tur + L_tur**3. + 3. * b_tur * (L_tur**2.))
     648      V_cld = N_cld * 4. * PI * (3. * (b_tur**2.) * L_tur + L_tur**3. - 3. * b_tur * (L_tur**2.))
     649      V_cld = abs(V_cld)
     650
     651      ! Repartition statistique des zones de contact nuage-ISSR et nuage-ciel clair
     652      sig = rnebss / (chi * rnebclr + rnebss)
     653      V_ss = MIN(sig * V_env, rnebss * V_cell)
     654      V_clr = MIN((1. - sig) * V_env, rnebclr * V_cell)
     655      V_cld = MIN(V_cld, rneb * V_cell)
     656      V_env = V_ss + V_clr
     657
     658      ! ISSR => rneb
     659      drnebss = -1. * V_ss / V_cell
     660      dqss = drnebss * qss / MAX(eps, rnebss)
     661
     662      ! Clear sky <=> rneb
     663      q_eq = V_env * qclr / MAX(eps, rnebclr) + V_cld * qcld / MAX(eps, rneb)
     664      q_eq = q_eq / (V_env + V_cld)
     665
     666      IF (q_eq>qsat) THEN
     667        drnebclr = - V_clr / V_cell
     668        dqclr = drnebclr * qclr / MAX(eps, rnebclr)
     669      ELSE
     670        drnebclr = V_cld / V_cell
     671        dqclr = drnebclr * qcld / MAX(eps, rneb)
     672      ENDIF
     673
     674      ! Maj des variables avec les tendances
     675      rnebclr = MAX(0.0, rnebclr + drnebclr)   !--OB ajout d'un max avec eps (il faudrait modified drnebclr pour le diag)
     676      qclr = MAX(0.0, qclr + dqclr)           !--OB ajout d'un max avec 0
     677
     678      rneb = rneb - drnebclr - drnebss
     679      qcld = qcld - dqclr - dqss
     680
     681      rnebss = MAX(0.0, rnebss + drnebss)     !--OB ajout d'un max avec eps (il faudrait modifier drnebss pour le diag)
     682      qss = MAX(0.0, qss + dqss)             !--OB ajout d'un max avec 0
     683
     684      ! Tendances pour le diagnostic
     685      drneb_tur(i, k) = (drnebclr + drnebss) / dtime  !--unit [s-1]
     686
     687    ENDIF ! rneb
     688
     689    !--add a source of cirrus from aviation contrails
     690    IF (ok_plane_contrail) THEN
     691      drneb_avi(i, k) = rnebss * flight_m(i, k) * contrail_cross_section / V_cell    !--tendency rneb due to aviation [s-1]
     692      drneb_avi(i, k) = MIN(drneb_avi(i, k), rnebss / dtime)                     !--majoration
     693      dqss_avi = qss * drneb_avi(i, k) / MAX(eps, rnebss)                          !--tendency q aviation [kg kg-1 s-1]
     694      rneb = rneb + drneb_avi(i, k) * dtime                                     !--add tendency to rneb
     695      qcld = qcld + dqss_avi * dtime                                           !--add tendency to qcld
     696      rnebss = rnebss - drneb_avi(i, k) * dtime                                 !--add tendency to rnebss
     697      qss = qss - dqss_avi * dtime                                             !--add tendency to qss
     698    ELSE
     699      drneb_avi(i, k) = 0.0
     700    ENDIF
     701
     702    ! Barrieres
     703    ! ISSR trop petite
     704    IF (rnebss<eps) THEN
     705      rneb = MIN(rneb + rnebss, 1.0 - eps) !--ajout OB barriere
     706      qcld = qcld + qss
     707      rnebss = 0.
     708      qss = 0.
     709    ENDIF
     710
     711    ! le nuage est trop petit
     712    IF (rneb<eps) THEN
     713      ! s'il y a une ISSR on met tout dans l'ISSR, sinon dans le
     714      ! clear sky
     715      IF (rnebss<eps) THEN
     716        rnebclr = 1.
     717        rnebss = 0. !--ajout OB
     718        qclr = q
     719      ELSE
     720        rnebss = MIN(rnebss + rneb, 1.0 - eps) !--ajout OB barriere
     721        qss = qss + qcld
     722      ENDIF
     723      rneb = 0.
     724      qcld = 0.
     725      qincld = qsat * gamma_ss
     726    ELSE
     727      qincld = qcld / rneb
     728    ENDIF
     729
     730    !--OB ajout borne superieure
     731    sum_rneb_rnebss = rneb + rnebss
     732    rneb = rneb * MIN(1. - eps, sum_rneb_rnebss) / MAX(eps, sum_rneb_rnebss)
     733    rnebss = rnebss * MIN(1. - eps, sum_rneb_rnebss) / MAX(eps, sum_rneb_rnebss)
     734
     735    ! On ecrit dans la memoire
     736    N1_ss(i, k) = pdf_N1
     737    N2_ss(i, k) = pdf_N2
     738
     739    !--Diagnostics only used from last iteration
     740    !--test
     741    !!Tcontr(i,k)=200.
     742    !!fcontrN(i,k)=1.0
     743    !!fcontrP(i,k)=0.5
     744
     745    !--slope of dilution line in exhaust
     746    !--kg H2O/kg fuel * J kg air-1 K-1 * Pa / (kg H2O / kg air * J kg fuel-1)
     747    Gcontr = EiH2O * RCPD * pplay / (eps_w * Qheat * (1. - eta))             !--Pa K-1
     748    !--critical T_LM below which no liquid contrail can form in exhaust
     749    !Tcontr(i,k) = 226.69+9.43*log(Gcontr-0.053)+0.72*(log(Gcontr-0.053))**2 !--K
     750    IF (Gcontr > 0.1) THEN
     751
     752      Tcontr = 226.69 + 9.43 * log(Gcontr - 0.053) + 0.72 * (log(Gcontr - 0.053))**2 !--K
     753      !print *,'Tcontr=',iter,i,k,eps_w,pplay,Gcontr,Tcontr(i,k)
     754      !--Psat with index 0 in FOEEW to get saturation wrt liquid water corresponding to Tcontr
     755      !qsatliqcontr = RESTT*FOEEW(Tcontr(i,k),0.)                               !--Pa
     756      qsatliqcontr = RESTT * FOEEW(Tcontr, 0.)                               !--Pa
     757      !--Critical water vapour above which there is contrail formation for ambiant temperature
     758      !qcontr(i,k) = Gcontr*(t-Tcontr(i,k)) + qsatliqcontr                      !--Pa
     759      qcontr = Gcontr * (t - Tcontr) + qsatliqcontr                      !--Pa
     760      !--Conversion of qcontr in specific humidity - method 1
     761      !qcontr(i,k) = RD/RV*qcontr(i,k)/pplay      !--so as to return to something similar to R2ES*FOEEW/pplay
     762      qcontr2 = RD / RV * qcontr / pplay      !--so as to return to something similar to R2ES*FOEEW/pplay
     763      !qcontr(i,k) = min(0.5,qcontr(i,k))         !--and then we apply the same correction term as for qsat
     764      qcontr2 = min(0.5, qcontr2)         !--and then we apply the same correction term as for qsat
     765      !zcor = 1./(1.-RETV*qcontr(i,k))            !--for consistency with qsat but is it correct at all?
     766      zcor = 1. / (1. - RETV * qcontr2)            !--for consistency with qsat but is it correct at all as p is dry?
     767      !zcor = 1./(1.+qcontr2)                 !--for consistency with qsat
     768      !qcontr(i,k) = qcontr(i,k)*zcor
     769      qcontr2 = qcontr2 * zcor
     770      qcontr2 = MAX(1.e-10, qcontr2)            !--eliminate negative values due to extrapolation on dilution curve
     771      !--Conversion of qcontr in specific humidity - method 2
     772      !qcontr(i,k) = eps_w*qcontr(i,k) / (pplay+eps_w*qcontr(i,k))
     773      !qcontr=MAX(1.E-10,qcontr)
     774      !qcontr2 = eps_w*qcontr / (pplay+eps_w*qcontr)
     775
     776      IF (t < Tcontr) THEN !--contrail formation is possible
     777
     778        !--compute fractions of persistent (P) and non-persistent(N) contrail potential regions
     779        !!IF (qcontr(i,k).GE.qsat) THEN
     780        IF (qcontr2>=qsat) THEN
     781          !--none of the unsaturated clear sky is prone for contrail formation
     782          !!fcontrN(i,k) = 0.0
     783          fcontrN = 0.0
     784
     785          !--integral of P(q) from qsat to qcontr in ISSR
     786          pdf_a = log(qsat / q) / (pdf_k * sqrt(2.))
     787          pdf_e1 = pdf_a + pdf_b
     788          IF (abs(pdf_e1)>=erf_lim) THEN
     789            pdf_e1 = sign(1., pdf_e1)
     790          ELSE
     791            pdf_e1 = erf(pdf_e1)
     792          ENDIF
     793
     794          !!pdf_a = log(MIN(qcontr(i,k),qvc)/q)/(pdf_k*sqrt(2.))
     795          pdf_a = log(MIN(qcontr2, qvc) / q) / (pdf_k * sqrt(2.))
     796          pdf_e2 = pdf_a + pdf_b
     797          IF (abs(pdf_e2)>=erf_lim) THEN
     798            pdf_e2 = sign(1., pdf_e2)
     799          ELSE
     800            pdf_e2 = erf(pdf_e2)
     801          ENDIF
     802
     803          !!fcontrP(i,k) = MAX(0., 0.5*(pdf_e1-pdf_e2))
     804          fcontrP = MAX(0., 0.5 * (pdf_e1 - pdf_e2))
     805
     806          pdf_a = log(qsat / q) / (pdf_k * sqrt(2.))
     807          pdf_e1 = pdf_a + pdf_b
     808          IF (abs(pdf_e1)>=erf_lim) THEN
     809            pdf_e1 = sign(1., pdf_e1)
     810          ELSE
     811            pdf_e1 = erf(pdf_e1)
     812          ENDIF
     813
     814          !!pdf_a = log(MIN(qcontr(i,k),qvc)/q)/(pdf_k*sqrt(2.))
     815          pdf_a = log(MIN(qcontr2, qvc) / q) / (pdf_k * sqrt(2.))
     816          pdf_e2 = pdf_a + pdf_b
     817          IF (abs(pdf_e2)>=erf_lim) THEN
     818            pdf_e2 = sign(1., pdf_e2)
     819          ELSE
     820            pdf_e2 = erf(pdf_e2)
     821          ENDIF
     822
     823          !!fcontrP(i,k) = MAX(0., 0.5*(pdf_e1-pdf_e2))
     824          fcontrP = MAX(0., 0.5 * (pdf_e1 - pdf_e2))
     825
     826          pdf_a = log(MAX(qsat, qvc) / q) / (pdf_k * sqrt(2.))
     827          pdf_e1 = pdf_a + pdf_b
     828          IF (abs(pdf_e1)>=erf_lim) THEN
     829            pdf_e1 = sign(1., pdf_e1)
     830          ELSE
     831            pdf_e1 = erf(pdf_e1)
     832          ENDIF
     833
     834          !!pdf_a = log(MIN(qcontr(i,k),MIN(gamma_prec*qvc,gamma_ss*qsat))/q)/(pdf_k*sqrt(2.))
     835          pdf_a = log(MIN(qcontr2, MIN(gamma_prec * qvc, gamma_ss * qsat)) / q) / (pdf_k * sqrt(2.))
     836          pdf_e2 = pdf_a + pdf_b
     837          IF (abs(pdf_e2)>=erf_lim) THEN
     838            pdf_e2 = sign(1., pdf_e2)
     839          ELSE
     840            pdf_e2 = erf(pdf_e2)
     841          ENDIF
     842
     843          !!fcontrP(i,k) = fcontrP(i,k) + MAX(0., 0.5*(1-pdf_N1)*(pdf_e1-pdf_e2))
     844          fcontrP = fcontrP + MAX(0., 0.5 * (1 - pdf_N1) * (pdf_e1 - pdf_e2))
     845
     846          pdf_a = log(gamma_prec * qvc / q) / (pdf_k * sqrt(2.))
     847          pdf_e1 = pdf_a + pdf_b
     848          IF (abs(pdf_e1)>=erf_lim) THEN
     849            pdf_e1 = sign(1., pdf_e1)
     850          ELSE
     851            pdf_e1 = erf(pdf_e1)
     852          ENDIF
     853
     854          !!pdf_a = log(MIN(qcontr(i,k),gamma_ss*qsat)/q)/(pdf_k*sqrt(2.))
     855          pdf_a = log(MIN(qcontr2, gamma_ss * qsat) / q) / (pdf_k * sqrt(2.))
     856          pdf_e2 = pdf_a + pdf_b
     857          IF (abs(pdf_e2)>=erf_lim) THEN
     858            pdf_e2 = sign(1., pdf_e2)
     859          ELSE
     860            pdf_e2 = erf(pdf_e2)
     861          ENDIF
     862
     863          !!fcontrP(i,k) = fcontrP(i,k) + MAX(0., 0.5*(1-pdf_N2)*(pdf_e1-pdf_e2))
     864          fcontrP = fcontrP + MAX(0., 0.5 * (1 - pdf_N2) * (pdf_e1 - pdf_e2))
     865
     866        ELSE  !--qcontr LT qsat
     867
     868          !--all of ISSR is prone for contrail formation
     869          !!fcontrP(i,k) = rnebss
     870          fcontrP = rnebss
     871
     872          !--integral of zq from qcontr to qsat in unsaturated clear-sky region
     873          !!pdf_a = log(qcontr(i,k)/q)/(pdf_k*sqrt(2.))
     874          pdf_a = log(qcontr2 / q) / (pdf_k * sqrt(2.))
     875          pdf_e1 = pdf_a + pdf_b   !--normalement pdf_b est deja defini
     876          IF (abs(pdf_e1)>=erf_lim) THEN
     877            pdf_e1 = sign(1., pdf_e1)
     878          ELSE
     879            pdf_e1 = erf(pdf_e1)
     880          ENDIF
     881
     882          pdf_a = log(qsat / q) / (pdf_k * sqrt(2.))
     883          pdf_e2 = pdf_a + pdf_b
     884          IF (abs(pdf_e2)>=erf_lim) THEN
     885            pdf_e2 = sign(1., pdf_e2)
     886          ELSE
     887            pdf_e2 = erf(pdf_e2)
     888          ENDIF
     889
     890          !!fcontrN(i,k) = 0.5*(pdf_e1-pdf_e2)
     891          fcontrN = 0.5 * (pdf_e1 - pdf_e2)
     892          !!fcontrN=2.0
     893
    467894        ENDIF
    468         pdf_e2 = 0.5*(1.+pdf_e2) ! integrale sous P pour q > gamma qsat
    469 
    470         IF (abs(pdf_e1-pdf_e2)<eps) THEN
    471            pdf_N1 = pdf_N2
    472         ELSE
    473            pdf_N1 = (rneb-pdf_N2*pdf_e2)/(pdf_e1-pdf_e2)
    474         ENDIF
    475 
    476         ! Barriere qui traite le cas gamma_prec = 1.
    477         IF (pdf_N1<=0.) THEN
    478            pdf_N1 = 0.
    479            IF (pdf_e2>eps) THEN
    480               pdf_N2 = rneb/pdf_e2
    481            ELSE
    482               pdf_N2 = 0.
    483            ENDIF
    484         ENDIF
    485      ENDIF
    486 
    487      ! Physique 1
    488      ! Sublimation
    489      IF (qvc<qsat) THEN
    490         pdf_a = log(qvc/q)/(pdf_k*sqrt(2.))
    491         pdf_e1 = pdf_a+pdf_b
    492         IF (abs(pdf_e1)>=erf_lim) THEN
    493            pdf_e1 = sign(1.,pdf_e1)
    494         ELSE
    495            pdf_e1 = erf(pdf_e1)
    496         ENDIF
    497 
    498         pdf_a = log(qsat/q)/(pdf_k*sqrt(2.))
    499         pdf_e2 = pdf_a+pdf_b
    500         IF (abs(pdf_e2)>=erf_lim) THEN
    501            pdf_e2 = sign(1.,pdf_e2)
    502         ELSE
    503            pdf_e2 = erf(pdf_e2)
    504         ENDIF
    505 
    506         pdf_e1 = 0.5*pdf_N1*(pdf_e1-pdf_e2)
    507        
    508         ! Calcul et ajout de la tendance
    509         drneb_sub(i,k) = - pdf_e1/dtime    !--unit [s-1]
    510         rneb = rneb + drneb_sub(i,k)*dtime
    511      ELSE
    512         drneb_sub(i,k) = 0.
    513      ENDIF
    514      
    515      ! NOTE : verifier si ca marche bien pour gamma proche de 1.
    516 
    517      ! Condensation
    518      IF (gamma_ss*qsat<gamma_prec*qvc) THEN
    519      
    520         pdf_a = log(gamma_ss*qsat/q)/(pdf_k*sqrt(2.))
    521         pdf_e1 = pdf_a+pdf_b
    522         IF (abs(pdf_e1)>=erf_lim) THEN
    523            pdf_e1 = sign(1.,pdf_e1)
    524         ELSE
    525            pdf_e1 = erf(pdf_e1)
    526         ENDIF
    527 
    528         pdf_a = log(gamma_prec*qvc/q)/(pdf_k*sqrt(2.))
    529         pdf_e2 = pdf_a+pdf_b
    530         IF (abs(pdf_e2)>=erf_lim) THEN
    531            pdf_e2 = sign(1.,pdf_e2)
    532         ELSE
    533            pdf_e2 = erf(pdf_e2)
    534         ENDIF
    535 
    536         pdf_e1 = 0.5*(1.-pdf_N1)*(pdf_e1-pdf_e2)
    537         pdf_e2 = 0.5*(1.-pdf_N2)*(1.+pdf_e2)
    538 
    539         ! Calcul et ajout de la tendance
    540         drneb_con(i,k) = (pdf_e1 + pdf_e2)/dtime         !--unit [s-1]
    541         rneb = rneb + drneb_con(i,k)*dtime
    542        
    543      ELSE
    544      
    545         pdf_a = log(gamma_ss*qsat/q)/(pdf_k*sqrt(2.))
    546         pdf_e1 = pdf_a+pdf_b
    547         IF (abs(pdf_e1)>=erf_lim) THEN
    548            pdf_e1 = sign(1.,pdf_e1)
    549         ELSE
    550            pdf_e1 = erf(pdf_e1)
    551         ENDIF
    552         pdf_e1 = 0.5*(1.-pdf_N2)*(1.+pdf_e1)
    553 
    554         ! Calcul et ajout de la tendance
    555         drneb_con(i,k) = pdf_e1/dtime         !--unit [s-1]
    556         rneb = rneb + drneb_con(i,k)*dtime
    557        
    558      ENDIF
    559 
    560      ! Calcul des grandeurs diagnostiques
    561      ! Determination des grandeurs ciel clair
    562      pdf_a = log(qsat/q)/(pdf_k*sqrt(2.))
    563      pdf_e1 = pdf_a+pdf_b
    564      IF (abs(pdf_e1)>=erf_lim) THEN
    565         pdf_e1 = sign(1.,pdf_e1)
    566      ELSE
    567         pdf_e1 = erf(pdf_e1)
    568      ENDIF
    569      pdf_e1 = 0.5*(1.-pdf_e1)
    570 
    571      pdf_e2 = pdf_a-pdf_b
    572      IF (abs(pdf_e2)>=erf_lim) THEN
    573         pdf_e2 = sign(1.,pdf_e2)
    574      ELSE
    575         pdf_e2 = erf(pdf_e2)
    576      ENDIF
    577      pdf_e2 = 0.5*q*(1.-pdf_e2)
    578 
    579      rnebclr = pdf_e1
    580      qclr = pdf_e2
    581 
    582      ! Determination de q_cld
    583      ! Partie 1
    584      pdf_a = log(max(qsat,qvc)/q)/(pdf_k*sqrt(2.))
    585      pdf_e1 = pdf_a-pdf_b
    586      IF (abs(pdf_e1)>=erf_lim) THEN
    587         pdf_e1 = sign(1.,pdf_e1)
    588      ELSE
    589         pdf_e1 = erf(pdf_e1)
    590      ENDIF
    591 
    592      pdf_a = log(min(gamma_ss*qsat,gamma_prec*qvc)/q)/(pdf_k*sqrt(2.))
    593      pdf_e2 = pdf_a-pdf_b
    594      IF (abs(pdf_e2)>=erf_lim) THEN
    595         pdf_e2 = sign(1.,pdf_e2)
    596      ELSE
    597         pdf_e2 = erf(pdf_e2)
    598      ENDIF
    599 
    600      pdf_e1 = 0.5*q*pdf_N1*(pdf_e1-pdf_e2)
    601      
    602      qcld = pdf_e1
    603 
    604      ! Partie 2 (sous condition)
    605      IF (gamma_ss*qsat>gamma_prec*qvc) THEN
    606         pdf_a = log(gamma_ss*qsat/q)/(pdf_k*sqrt(2.))
    607         pdf_e1 = pdf_a-pdf_b
    608         IF (abs(pdf_e1)>=erf_lim) THEN
    609            pdf_e1 = sign(1.,pdf_e1)
    610         ELSE
    611            pdf_e1 = erf(pdf_e1)
    612         ENDIF
    613 
    614         pdf_e2 = 0.5*q*pdf_N2*(pdf_e2-pdf_e1)
    615 
    616         qcld = qcld + pdf_e2
    617 
    618         pdf_e2 = pdf_e1 
    619      ENDIF
    620 
    621      ! Partie 3
    622      pdf_e2 = 0.5*q*(1.+pdf_e2)
    623      
    624      qcld = qcld + pdf_e2
    625 
    626      ! Fin du calcul de q_cld
    627      
    628      ! Determination des grandeurs ISSR via les equations de conservation
    629      rneb=MIN(rneb, 1. - rnebclr - eps)      !--ajout OB - barrière
    630      rnebss = MAX(0.0, 1. - rnebclr - rneb)  !--ajout OB
    631      qss = MAX(0.0, q - qclr - qcld)         !--ajout OB
    632 
    633      ! Physique 2 : Turbulence
    634      IF (rneb>eps.AND.rneb<1.-eps) THEN ! rneb != 0 and != 1
    635 
    636        tke = pbl_tke(i,k,is_ave)
    637        ! A MODIFIER formule a revoir
    638        L_tur = min(l_turb, sqrt(tke)*dtime)
    639 
    640        ! On fait pour l'instant l'hypothese a = 3b. V = 4/3 pi a b**2 = alpha_cld
    641        ! donc b = alpha_cld/4pi **1/3.
    642        b_tur = (rneb*V_cell/4./PI/N_cld)**(1./3.)
    643        ! On verifie que la longeur de melange n'est pas trop grande
    644        IF (L_tur>b_tur) THEN
    645           L_tur = b_tur
    646        ENDIF
    647        
    648        V_env = N_cld*4.*PI*(3.*(b_tur**2.)*L_tur + L_tur**3. + 3.*b_tur*(L_tur**2.))
    649        V_cld = N_cld*4.*PI*(3.*(b_tur**2.)*L_tur + L_tur**3. - 3.*b_tur*(L_tur**2.))
    650        V_cld = abs(V_cld)
    651 
    652        ! Repartition statistique des zones de contact nuage-ISSR et nuage-ciel clair
    653        sig = rnebss/(chi*rnebclr+rnebss)
    654        V_ss = MIN(sig*V_env,rnebss*V_cell)
    655        V_clr = MIN((1.-sig)*V_env,rnebclr*V_cell)
    656        V_cld = MIN(V_cld,rneb*V_cell)
    657        V_env = V_ss + V_clr
    658 
    659        ! ISSR => rneb
    660        drnebss = -1.*V_ss/V_cell
    661        dqss = drnebss*qss/MAX(eps,rnebss)
    662 
    663        ! Clear sky <=> rneb
    664        q_eq = V_env*qclr/MAX(eps,rnebclr) + V_cld*qcld/MAX(eps,rneb)
    665        q_eq = q_eq/(V_env + V_cld)
    666 
    667        IF (q_eq>qsat) THEN
    668           drnebclr = - V_clr/V_cell
    669           dqclr = drnebclr*qclr/MAX(eps,rnebclr)
    670        ELSE
    671           drnebclr = V_cld/V_cell
    672           dqclr = drnebclr*qcld/MAX(eps,rneb)
    673        ENDIF
    674 
    675        ! Maj des variables avec les tendances
    676        rnebclr = MAX(0.0,rnebclr + drnebclr)   !--OB ajout d'un max avec eps (il faudrait modified drnebclr pour le diag)
    677        qclr = MAX(0.0, qclr + dqclr)           !--OB ajout d'un max avec 0
    678 
    679        rneb = rneb - drnebclr - drnebss
    680        qcld = qcld - dqclr - dqss
    681 
    682        rnebss = MAX(0.0,rnebss + drnebss)     !--OB ajout d'un max avec eps (il faudrait modifier drnebss pour le diag)
    683        qss = MAX(0.0, qss + dqss)             !--OB ajout d'un max avec 0
    684 
    685        ! Tendances pour le diagnostic
    686        drneb_tur(i,k) = (drnebclr + drnebss)/dtime  !--unit [s-1]
    687 
    688      ENDIF ! rneb
    689 
    690      !--add a source of cirrus from aviation contrails
    691      IF (ok_plane_contrail) THEN
    692        drneb_avi(i,k) = rnebss*flight_m(i,k)*contrail_cross_section/V_cell    !--tendency rneb due to aviation [s-1]
    693        drneb_avi(i,k) = MIN(drneb_avi(i,k), rnebss/dtime)                     !--majoration
    694        dqss_avi = qss*drneb_avi(i,k)/MAX(eps,rnebss)                          !--tendency q aviation [kg kg-1 s-1]
    695        rneb = rneb + drneb_avi(i,k)*dtime                                     !--add tendency to rneb
    696        qcld = qcld + dqss_avi*dtime                                           !--add tendency to qcld
    697        rnebss = rnebss - drneb_avi(i,k)*dtime                                 !--add tendency to rnebss
    698        qss = qss - dqss_avi*dtime                                             !--add tendency to qss
    699      ELSE
    700        drneb_avi(i,k)=0.0
    701      ENDIF
    702 
    703      ! Barrieres
    704      ! ISSR trop petite
    705      IF (rnebss<eps) THEN
    706         rneb = MIN(rneb + rnebss,1.0-eps) !--ajout OB barriere
    707         qcld = qcld + qss
    708         rnebss = 0.
    709         qss = 0.
    710      ENDIF
    711 
    712      ! le nuage est trop petit
    713      IF (rneb<eps) THEN
    714         ! s'il y a une ISSR on met tout dans l'ISSR, sinon dans le
    715         ! clear sky
    716         IF (rnebss<eps) THEN
    717            rnebclr = 1.
    718            rnebss = 0. !--ajout OB
    719            qclr = q
    720         ELSE
    721            rnebss = MIN(rnebss + rneb,1.0-eps) !--ajout OB barriere
    722            qss = qss + qcld
    723         ENDIF
    724         rneb = 0.
    725         qcld = 0.
    726         qincld = qsat * gamma_ss
    727      ELSE
    728         qincld = qcld / rneb
    729      ENDIF
    730 
    731      !--OB ajout borne superieure
    732      sum_rneb_rnebss=rneb+rnebss
    733      rneb=rneb*MIN(1.-eps,sum_rneb_rnebss)/MAX(eps,sum_rneb_rnebss)
    734      rnebss=rnebss*MIN(1.-eps,sum_rneb_rnebss)/MAX(eps,sum_rneb_rnebss)
    735 
    736      ! On ecrit dans la memoire
    737      N1_ss(i,k) = pdf_N1
    738      N2_ss(i,k) = pdf_N2
    739    
    740      !--Diagnostics only used from last iteration
    741      !--test
    742      !!Tcontr(i,k)=200.
    743      !!fcontrN(i,k)=1.0
    744      !!fcontrP(i,k)=0.5
    745 
    746      !--slope of dilution line in exhaust
    747      !--kg H2O/kg fuel * J kg air-1 K-1 * Pa / (kg H2O / kg air * J kg fuel-1)
    748      Gcontr = EiH2O * RCPD * pplay / (eps_w*Qheat*(1.-eta))             !--Pa K-1
    749      !--critical T_LM below which no liquid contrail can form in exhaust
    750      !Tcontr(i,k) = 226.69+9.43*log(Gcontr-0.053)+0.72*(log(Gcontr-0.053))**2 !--K
    751      IF (Gcontr > 0.1) THEN
    752 
    753        Tcontr = 226.69+9.43*log(Gcontr-0.053)+0.72*(log(Gcontr-0.053))**2 !--K
    754        !print *,'Tcontr=',iter,i,k,eps_w,pplay,Gcontr,Tcontr(i,k)
    755        !--Psat with index 0 in FOEEW to get saturation wrt liquid water corresponding to Tcontr
    756        !qsatliqcontr = RESTT*FOEEW(Tcontr(i,k),0.)                               !--Pa
    757        qsatliqcontr = RESTT*FOEEW(Tcontr,0.)                               !--Pa
    758        !--Critical water vapour above which there is contrail formation for ambiant temperature
    759        !qcontr(i,k) = Gcontr*(t-Tcontr(i,k)) + qsatliqcontr                      !--Pa
    760        qcontr = Gcontr*(t-Tcontr) + qsatliqcontr                      !--Pa
    761        !--Conversion of qcontr in specific humidity - method 1
    762        !qcontr(i,k) = RD/RV*qcontr(i,k)/pplay      !--so as to return to something similar to R2ES*FOEEW/pplay
    763        qcontr2 = RD/RV*qcontr/pplay      !--so as to return to something similar to R2ES*FOEEW/pplay
    764        !qcontr(i,k) = min(0.5,qcontr(i,k))         !--and then we apply the same correction term as for qsat
    765        qcontr2 = min(0.5,qcontr2)         !--and then we apply the same correction term as for qsat
    766        !zcor = 1./(1.-RETV*qcontr(i,k))            !--for consistency with qsat but is it correct at all?
    767        zcor = 1./(1.-RETV*qcontr2)            !--for consistency with qsat but is it correct at all as p is dry?
    768        !zcor = 1./(1.+qcontr2)                 !--for consistency with qsat
    769        !qcontr(i,k) = qcontr(i,k)*zcor
    770        qcontr2 = qcontr2*zcor
    771        qcontr2=MAX(1.e-10,qcontr2)            !--eliminate negative values due to extrapolation on dilution curve
    772        !--Conversion of qcontr in specific humidity - method 2
    773        !qcontr(i,k) = eps_w*qcontr(i,k) / (pplay+eps_w*qcontr(i,k))
    774        !qcontr=MAX(1.E-10,qcontr)
    775        !qcontr2 = eps_w*qcontr / (pplay+eps_w*qcontr)
    776 
    777        IF (t < Tcontr) THEN !--contrail formation is possible
    778 
    779        !--compute fractions of persistent (P) and non-persistent(N) contrail potential regions
    780        !!IF (qcontr(i,k).GE.qsat) THEN
    781        IF (qcontr2>=qsat) THEN
    782          !--none of the unsaturated clear sky is prone for contrail formation
    783          !!fcontrN(i,k) = 0.0
    784          fcontrN = 0.0
    785 
    786          !--integral of P(q) from qsat to qcontr in ISSR
    787          pdf_a = log(qsat/q)/(pdf_k*sqrt(2.))
    788          pdf_e1 = pdf_a+pdf_b
    789          IF (abs(pdf_e1)>=erf_lim) THEN
    790             pdf_e1 = sign(1.,pdf_e1)
    791          ELSE
    792             pdf_e1 = erf(pdf_e1)
    793          ENDIF
    794 
    795          !!pdf_a = log(MIN(qcontr(i,k),qvc)/q)/(pdf_k*sqrt(2.))
    796          pdf_a = log(MIN(qcontr2,qvc)/q)/(pdf_k*sqrt(2.))
    797          pdf_e2 = pdf_a+pdf_b
    798          IF (abs(pdf_e2)>=erf_lim) THEN
    799             pdf_e2 = sign(1.,pdf_e2)
    800          ELSE
    801             pdf_e2 = erf(pdf_e2)
    802          ENDIF
    803 
    804          !!fcontrP(i,k) = MAX(0., 0.5*(pdf_e1-pdf_e2))
    805          fcontrP = MAX(0., 0.5*(pdf_e1-pdf_e2))
    806 
    807          pdf_a = log(qsat/q)/(pdf_k*sqrt(2.))
    808          pdf_e1 = pdf_a+pdf_b
    809          IF (abs(pdf_e1)>=erf_lim) THEN
    810             pdf_e1 = sign(1.,pdf_e1)
    811          ELSE
    812             pdf_e1 = erf(pdf_e1)
    813          ENDIF
    814 
    815          !!pdf_a = log(MIN(qcontr(i,k),qvc)/q)/(pdf_k*sqrt(2.))
    816          pdf_a = log(MIN(qcontr2,qvc)/q)/(pdf_k*sqrt(2.))
    817          pdf_e2 = pdf_a+pdf_b
    818          IF (abs(pdf_e2)>=erf_lim) THEN
    819             pdf_e2 = sign(1.,pdf_e2)
    820          ELSE
    821             pdf_e2 = erf(pdf_e2)
    822          ENDIF
    823 
    824          !!fcontrP(i,k) = MAX(0., 0.5*(pdf_e1-pdf_e2))
    825          fcontrP = MAX(0., 0.5*(pdf_e1-pdf_e2))
    826 
    827          pdf_a = log(MAX(qsat,qvc)/q)/(pdf_k*sqrt(2.))
    828          pdf_e1 = pdf_a+pdf_b
    829          IF (abs(pdf_e1)>=erf_lim) THEN
    830             pdf_e1 = sign(1.,pdf_e1)
    831          ELSE
    832             pdf_e1 = erf(pdf_e1)
    833          ENDIF
    834 
    835          !!pdf_a = log(MIN(qcontr(i,k),MIN(gamma_prec*qvc,gamma_ss*qsat))/q)/(pdf_k*sqrt(2.))
    836          pdf_a = log(MIN(qcontr2,MIN(gamma_prec*qvc,gamma_ss*qsat))/q)/(pdf_k*sqrt(2.))
    837          pdf_e2 = pdf_a+pdf_b
    838          IF (abs(pdf_e2)>=erf_lim) THEN
    839             pdf_e2 = sign(1.,pdf_e2)
    840          ELSE
    841             pdf_e2 = erf(pdf_e2)
    842          ENDIF
    843 
    844          !!fcontrP(i,k) = fcontrP(i,k) + MAX(0., 0.5*(1-pdf_N1)*(pdf_e1-pdf_e2))
    845          fcontrP = fcontrP + MAX(0., 0.5*(1-pdf_N1)*(pdf_e1-pdf_e2))
    846 
    847          pdf_a = log(gamma_prec*qvc/q)/(pdf_k*sqrt(2.))
    848          pdf_e1 = pdf_a+pdf_b
    849          IF (abs(pdf_e1)>=erf_lim) THEN
    850             pdf_e1 = sign(1.,pdf_e1)
    851          ELSE
    852             pdf_e1 = erf(pdf_e1)
    853          ENDIF
    854 
    855          !!pdf_a = log(MIN(qcontr(i,k),gamma_ss*qsat)/q)/(pdf_k*sqrt(2.))
    856          pdf_a = log(MIN(qcontr2,gamma_ss*qsat)/q)/(pdf_k*sqrt(2.))
    857          pdf_e2 = pdf_a+pdf_b
    858          IF (abs(pdf_e2)>=erf_lim) THEN
    859             pdf_e2 = sign(1.,pdf_e2)
    860          ELSE
    861             pdf_e2 = erf(pdf_e2)
    862          ENDIF
    863 
    864          !!fcontrP(i,k) = fcontrP(i,k) + MAX(0., 0.5*(1-pdf_N2)*(pdf_e1-pdf_e2))
    865          fcontrP = fcontrP + MAX(0., 0.5*(1-pdf_N2)*(pdf_e1-pdf_e2))
    866 
    867        ELSE  !--qcontr LT qsat
    868 
    869          !--all of ISSR is prone for contrail formation
    870          !!fcontrP(i,k) = rnebss
    871          fcontrP = rnebss
    872 
    873          !--integral of zq from qcontr to qsat in unsaturated clear-sky region
    874          !!pdf_a = log(qcontr(i,k)/q)/(pdf_k*sqrt(2.))
    875          pdf_a = log(qcontr2/q)/(pdf_k*sqrt(2.))
    876          pdf_e1 = pdf_a+pdf_b   !--normalement pdf_b est deja defini
    877          IF (abs(pdf_e1)>=erf_lim) THEN
    878             pdf_e1 = sign(1.,pdf_e1)
    879          ELSE
    880             pdf_e1 = erf(pdf_e1)
    881          ENDIF
    882 
    883          pdf_a = log(qsat/q)/(pdf_k*sqrt(2.))
    884          pdf_e2 = pdf_a+pdf_b
    885          IF (abs(pdf_e2)>=erf_lim) THEN
    886             pdf_e2 = sign(1.,pdf_e2)
    887          ELSE
    888             pdf_e2 = erf(pdf_e2)
    889          ENDIF
    890 
    891          !!fcontrN(i,k) = 0.5*(pdf_e1-pdf_e2)
    892          fcontrN = 0.5*(pdf_e1-pdf_e2)
    893          !!fcontrN=2.0
    894 
    895        ENDIF
    896 
    897        ENDIF !-- t < Tcontr
    898 
    899      ENDIF !-- Gcontr > 0.1
    900 
    901 
    902 END SUBROUTINE ice_sursat
    903 
    904 !*******************************************************************
     895
     896      ENDIF !-- t < Tcontr
     897
     898    ENDIF !-- Gcontr > 0.1
     899
     900  END SUBROUTINE ice_sursat
     901
     902  !*******************************************************************
    905903
    906904END MODULE ice_sursat_mod

  • LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_ts2.f90

    r5140 r5143  
    6767  USE indice_sol_mod
    6868  USE lmdz_comsoil, ONLY: inertie_sol, inertie_sno, inertie_sic, inertie_lic, iflag_sic, iflag_inertie
     69  USE lmdz_YOETHF
     70  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    6971
    7072  IMPLICIT NONE
    … …  
    7577
    7678  INCLUDE "YOMCST.h"
    77   INCLUDE "YOETHF.h"
    78   INCLUDE "FCTTRE.h"
    7979  ! INCLUDE "indicesol.h"
    8080  ! include  "LMDZphy.inc"
    … …  
    263263            * TsisSV(ig, isl)                     & !
    264264            * TsisSV(ig, isl)
    265     IRs__D(ig) = dIRsdT(ig)* TsisSV(ig, isl) * 0.75                  !:
     265    IRs__D(ig) = dIRsdT(ig) * TsisSV(ig, isl) * 0.75                  !:
    266266  END DO
    267267  !hj

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

    r5142 r5143  
     1MODULE lmdz_fcttre
     2  !     ------------------------------------------------------------------
     3  !     This COMDECK includes the Thermodynamical functions for the cy39
     4  !       ECMWF Physics package.
     5  !       Consistent with YOMCST Basic physics constants, assuming the
     6  !       partial pressure of water vapour is given by a first order
     7  !       Taylor expansion of Qs(T) w.r.t. to Temperature, using constants
     8  !       in YOETHF
     9  !     ------------------------------------------------------------------
    110
    2 ! $Header$
     11  IMPLICIT NONE; PRIVATE
     12  PUBLIC foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    313
     14  LOGICAL, PARAMETER :: thermcep = .TRUE.
    415
    5 !  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
    6 !                 veillez  n'utiliser que des ! pour les commentaires
    7 !                 et  bien positionner les & des lignes de continuation
    8 !                 (les placer en colonne 6 et en colonne 73)
     16CONTAINS
    917
    10 !     ------------------------------------------------------------------
    11 !     This COMDECK includes the Thermodynamical functions for the cy39
    12 !       ECMWF Physics package.
    13 !       Consistent with YOMCST Basic physics constants, assuming the
    14 !       partial pressure of water vapour is given by a first order
    15 !       Taylor expansion of Qs(T) w.r.t. to Temperature, using constants
    16 !       in YOETHF
    17 !     ------------------------------------------------------------------
    18       REAL PTARG, PDELARG, P5ARG, PQSARG, PCOARG
    19       REAL FOEEW, FOEDE, qsats, qsatl, dqsats, dqsatl
    20       LOGICAL thermcep
    21       PARAMETER (thermcep=.TRUE.)
     18  REAL FUNCTION foeew (ptarg, pdelarg)
     19    USE lmdz_YOETHF, ONLY: r3ies, r3les, r4ies, r4les
     20    INCLUDE "YOMCST.h"  ! rtt
     21    REAL, INTENT(IN) :: ptarg, pdelarg
     22    foeew = exp ((r3les * (1. - pdelarg) + r3ies * pdelarg) * (ptarg - rtt) &
     23            / (ptarg - (r4les * (1. - pdelarg) + r4ies * pdelarg)))
     24  END FUNCTION foeew
    2225
    23       FOEEW ( PTARG,PDELARG ) = EXP (                                   &
    24                 (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)        &
    25        / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
     26  REAL FUNCTION foede (ptarg, pdelarg, p5arg, pqsarg, pcoarg)
     27    USE lmdz_YOETHF, ONLY: r4ies, r4les
     28    REAL, INTENT(IN) :: ptarg, pdelarg, p5arg, pqsarg, pcoarg
     29    foede = pqsarg * pcoarg * p5arg / (ptarg - (r4les * (1. - pdelarg) + r4ies * pdelarg))**2
     30  END FUNCTION foede
    2631
    27       FOEDE ( PTARG,PDELARG,P5ARG,PQSARG,PCOARG ) = PQSARG*PCOARG*P5ARG &
    28        / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG))**2
     32  REAL FUNCTION qsats(ptarg)
     33    REAL, INTENT(IN) :: ptarg
     34    qsats = 100.0 * 0.622 * 10.0 ** (2.07023 - 0.00320991 * ptarg - 2484.896 / ptarg + 3.56654 * log10(ptarg))
     35  END FUNCTION qsats
    2936
    30       qsats(ptarg) = 100.0 * 0.622 * 10.0                               &
    31                  ** (2.07023 - 0.00320991 * ptarg                       &
    32                  - 2484.896 / ptarg + 3.56654 * LOG10(ptarg))
    33       qsatl(ptarg) = 100.0 * 0.622 * 10.0                               &
    34                  ** (23.8319 - 2948.964 / ptarg                         &
    35                  - 5.028 * LOG10(ptarg)                                 &
    36                  - 29810.16 * EXP( - 0.0699382 * ptarg)                 &
    37                  + 25.21935 * EXP( - 2999.924 / ptarg))
     37  REAL FUNCTION qsatl(ptarg)
     38    REAL, INTENT(IN) :: ptarg
     39    qsatl = 100.0 * 0.622 * 10.0 ** (23.8319 - 2948.964 / ptarg - 5.028 * log10(ptarg) &
     40            - 29810.16 * exp(- 0.0699382 * ptarg) + 25.21935 * exp(- 2999.924 / ptarg))
     41  END FUNCTION qsatl
    3842
    39       dqsats(ptarg,pqsarg) = RLVTT/RCPD*pqsarg * (3.56654/ptarg         &
    40                            +2484.896*LOG(10.)/ptarg**2                  &
    41                            -0.00320991*LOG(10.))
    42       dqsatl(ptarg,pqsarg) = RLVTT/RCPD*pqsarg*LOG(10.)*                &
    43                       (2948.964/ptarg**2-5.028/LOG(10.)/ptarg           &
    44                       +25.21935*2999.924/ptarg**2*EXP(-2999.924/ptarg)  &
    45                       +29810.16*0.0699382*EXP(-0.0699382*ptarg))
     43  REAL FUNCTION dqsats(ptarg, pqsarg)
     44    REAL, INTENT(IN) :: ptarg, pqsarg
     45    INCLUDE "YOMCST.h"  ! rlvtt, rcpd
     46    dqsats = rlvtt / rcpd * pqsarg * (3.56654 / ptarg + 2484.896 * log(10.) / ptarg**2 - 0.00320991 * log(10.))
     47  END FUNCTION dqsats
     48
     49  REAL FUNCTION dqsatl(ptarg, pqsarg)
     50    REAL, INTENT(IN) :: ptarg, pqsarg
     51    INCLUDE "YOMCST.h"  ! rlvtt, rcpd
     52    dqsatl = rlvtt / rcpd * pqsarg * log(10.) * (2948.964 / ptarg**2 - 5.028 / log(10.) / ptarg &
     53            + 25.21935 * 2999.924 / ptarg**2 * exp(-2999.924 / ptarg) + &
     54            29810.16 * 0.0699382 * exp(-0.0699382 * ptarg))
     55  END FUNCTION dqsatl
     56
     57END MODULE lmdz_fcttre

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

    r5142 r5143  
     1!*    *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS
     2MODULE lmdz_YOEGWD
     3  IMPLICIT NONE; PRIVATE
     4  PUBLIC GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     5          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
    16
    2 ! $Header$
     7  INTEGER NKTOPG, NSTRA
     8  REAL GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT
     9  REAL GHMAX, GRAHILO, GSIGCR, GSSEC, GTSEC, GVSEC
    310
    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)
    8 !     -----------------------------------------------------------------
    9 !*    *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS
    10 !     -----------------------------------------------------------------
     11  REAL GWD_RANDO_RUWMAX
     12  !     Maximum Eliassen-Palm flux at launch level, in "FLOTT_GWD_rando"
    1113
    12       INTEGER NKTOPG,NSTRA
    13       REAL GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT
    14       REAL GHMAX,GRAHILO,GSIGCR,GSSEC,GTSEC,GVSEC
     14  REAL GWD_RANDO_SAT ! saturation parameter in "FLOTT_GWD_rando"
     15  !     S_c in equation (12) of Lott (JGR, vol 118, page 8897, 2013)
    1516
    16       REAL GWD_RANDO_RUWMAX
    17 !     Maximum Eliassen-Palm flux at launch level, in "FLOTT_GWD_rando"
     17  REAL GWD_FRONT_RUWMAX, GWD_FRONT_SAT
     18  ! Same as GWD_RANDO params but for fronal GWs
    1819
    19       REAL GWD_RANDO_SAT ! saturation parameter in "FLOTT_GWD_rando"
    20 !     S_c in equation (12) of Lott (JGR, vol 118, page 8897, 2013)
    21 
    22       REAL GWD_FRONT_RUWMAX,GWD_FRONT_SAT
    23 ! Same as GWD_RANDO params but for fronal GWs
    24 
    25 
    26       COMMON/YOEGWD/ GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT,        &
    27            GHMAX,GRAHILO,GSIGCR,NKTOPG,NSTRA,GSSEC,GTSEC,GVSEC,         &
    28            GWD_RANDO_RUWMAX, gwd_rando_sat,                             &
    29            GWD_FRONT_RUWMAX, gwd_front_sat
    30 
    31       save /YOEGWD/
    32 !$OMP THREADPRIVATE(/YOEGWD/)
     20  !$OMP THREADPRIVATE(GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     21  !$OMP          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat)
     22END MODULE lmdz_YOEGWD

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

    r5142 r5143  
     1MODULE lmdz_YOETHF
     2  !*    COMMON *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS
    13
    2 ! $Id$
     4  !     *R__ES*   *CONSTANTS USED FOR COMPUTATION OF SATURATION
     5  !                MIXING RATIO OVER LIQUID WATER(*R_LES*) OR
     6  !                ICE(*R_IES*).
     7  !     *RVTMP2*  *RVTMP2=RCPV/RCPD-1.
     8  !     *RHOH2O*  *DENSITY OF LIQUID WATER.   (RATM/100.)
     9  IMPLICIT NONE; PRIVATE
     10  PUBLIC R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES, RVTMP2, RHOH2O, R5ALVCP, &
     11          R5ALSCP, RALVDCP, RALSDCP, RALFDCP, RTWAT, RTBER, RTBERCU, RTICE, RTICECU, &
     12          RTWAT_RTICE_R, RTWAT_RTICECU_R, RKOOP1, RKOOP2, OK_BAD_ECMWF_THERMO
    313
    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)
     14  REAL R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES
     15  REAL RVTMP2, RHOH2O
     16  REAL R5ALVCP, R5ALSCP, RALVDCP, RALSDCP, RALFDCP, RTWAT, RTBER, RTBERCU
     17  REAL RTICE, RTICECU, RTWAT_RTICE_R, RTWAT_RTICECU_R, RKOOP1, RKOOP2
     18  LOGICAL OK_BAD_ECMWF_THERMO ! If TRUE, then variables set by rrtm/suphec.F90
     19  ! If FALSE, then variables set by suphel.F90
    820
    9 !*    COMMON *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS
    10 
    11 !     *R__ES*   *CONSTANTS USED FOR COMPUTATION OF SATURATION
    12 !                MIXING RATIO OVER LIQUID WATER(*R_LES*) OR
    13 !                ICE(*R_IES*).
    14 !     *RVTMP2*  *RVTMP2=RCPV/RCPD-1.
    15 !     *RHOH2O*  *DENSITY OF LIQUID WATER.   (RATM/100.)
    16 
    17       REAL R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES
    18       REAL RVTMP2, RHOH2O
    19       REAL R5ALVCP,R5ALSCP,RALVDCP,RALSDCP,RALFDCP,RTWAT,RTBER,RTBERCU
    20       REAL RTICE,RTICECU,RTWAT_RTICE_R,RTWAT_RTICECU_R,RKOOP1,RKOOP2
    21       LOGICAL OK_BAD_ECMWF_THERMO ! If TRUE, then variables set by rrtm/suphec.F90
    22                                   ! If FALSE, then variables set by suphel.F90
    23       COMMON /YOETHF/R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES,    &
    24                      RVTMP2, RHOH2O,                                    &
    25                      R5ALVCP,R5ALSCP,RALVDCP,RALSDCP,                   &
    26                      RALFDCP,RTWAT,RTBER,RTBERCU,                       &
    27                      RTICE,RTICECU,RTWAT_RTICE_R,RTWAT_RTICECU_R,RKOOP1,&
    28                      RKOOP2,                                            &
    29                      OK_BAD_ECMWF_THERMO
    30 
    31 !$OMP THREADPRIVATE(/YOETHF/)
     21  !$OMP THREADPRIVATE(R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES, RVTMP2, RHOH2O, R5ALVCP, &
     22  !$OMP      R5ALSCP, RALVDCP, RALSDCP, RALFDCP, RTWAT, RTBER, RTBERCU, RTICE, RTICECU,&
     23  !$OMP      RTWAT_RTICE_R, RTWAT_RTICECU_R, RKOOP1, RKOOP2, OK_BAD_ECMWF_THERMO)
     24END MODULE lmdz_YOETHF

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

    r5134 r5143  
    4444    USE phys_local_var_mod, ONLY: zw2       ! Variables internes non sauvegardees de la physique
    4545    USE lmdz_abort_physic, ONLY: abort_physic
     46    USE lmdz_YOETHF
    4647
    4748    IMPLICIT NONE
    … …  
    7475
    7576    include "YOMCST.h"
    76     include "YOETHF.h"
    7777
    7878    ! Local variables

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

    r5134 r5143  
    1414
    1515      USE lmdz_cloudth_ini, ONLY: iflag_cloudth_vert,iflag_ratqs
     16      USE lmdz_YOETHF
     17      USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    1618
    1719      IMPLICIT NONE
    … …  
    2628
    2729      INCLUDE "YOMCST.h"
    28       INCLUDE "YOETHF.h"
    29       INCLUDE "FCTTRE.h"
    3030
    3131      INTEGER itap,ind1,ind2
    … …  
    265265
    266266      USE lmdz_cloudth_ini, ONLY: iflag_cloudth_vert, vert_alpha
     267      USE lmdz_YOETHF
     268      USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    267269
    268270      IMPLICIT NONE
    269271
    270272      INCLUDE "YOMCST.h"
    271       INCLUDE "YOETHF.h"
    272       INCLUDE "FCTTRE.h"
    273      
     273
    274274      INTEGER itap,ind1,ind2
    275275      INTEGER ngrid,klev,klon,l,ig
    … …  
    585585
    586586      USE lmdz_cloudth_ini, ONLY: iflag_cloudth_vert
     587      USE lmdz_YOETHF
     588      USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    587589
    588590      IMPLICIT NONE
    … …  
    597599
    598600      INCLUDE "YOMCST.h"
    599       INCLUDE "YOETHF.h"
    600       INCLUDE "FCTTRE.h"
    601601
    602602      INTEGER, INTENT(IN) :: ind2
    … …  
    818818      USE lmdz_cloudth_ini, ONLY: iflag_cloudth_vert,iflag_ratqs
    819819      USE lmdz_cloudth_ini, ONLY: vert_alpha,vert_alpha_th, sigma1s_factor, sigma1s_power , sigma2s_factor , sigma2s_power , cloudth_ratqsmin , iflag_cloudth_vert_noratqs
     820      USE lmdz_YOETHF
     821      USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    820822
    821823      IMPLICIT NONE
    822824
    823 
    824 
    825825      INCLUDE "YOMCST.h"
    826       INCLUDE "YOETHF.h"
    827       INCLUDE "FCTTRE.h"
    828      
     826
    829827      INTEGER itap,ind1,ind2
    830828      INTEGER ngrid,klev,klon,l,ig
    … …  
    12311229
    12321230      USE lmdz_cloudth_ini, ONLY: iflag_cloudth_vert
     1231      USE lmdz_YOETHF
     1232      USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    12331233
    12341234      IMPLICIT NONE
    12351235
    1236 
    12371236      INCLUDE "YOMCST.h"
    1238       INCLUDE "YOETHF.h"
    1239       INCLUDE "FCTTRE.h"
    12401237
    12411238

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

    r5140 r5143  
    2727    USE dimphy
    2828    USE infotrac_phy, ONLY: nbtr
     29    USE lmdz_YOETHF
     30    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     31
    2932    IMPLICIT NONE
    3033    ! ======================================================================
    … …  
    193196
    194197    include "YOMCST.h"
    195     include "YOETHF.h"
    196     include "FCTTRE.h"
    197198
    198199    IF (first) THEN

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

    r5134 r5143  
    2424  USE lmdz_lscp_ini, ONLY: cld_tau_lsc, cld_tau_con, cld_lc_lsc, cld_lc_con
    2525  USE lmdz_lscp_ini, ONLY: reevap_ice, iflag_bergeron, iflag_fisrtilp_qsat, iflag_pdf
    26 
    27 
     26  USE lmdz_YOETHF
     27  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    2828
    2929  IMPLICIT NONE
    … …  
    5454  !======================================================================
    5555  include "YOMCST.h"
    56   include "YOETHF.h"
    57   include "FCTTRE.h"
    5856
    5957  ! Principaux inputs:

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

    r5117 r5143  
    511511    ! Calculate qsat following ECMWF method
    512512!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    513 
     513  USE lmdz_YOETHF
     514  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    514515
    515516    IMPLICIT NONE
    516517
    517518    include "YOMCST.h"
    518     include "YOETHF.h"
    519     include "FCTTRE.h"
    520519
    521520    INTEGER, INTENT(IN) :: klon  ! number of horizontal grid points

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

    r5117 r5143  
    1313! total water subgrid distribution.
    1414!=============================================
    15 
     15USE lmdz_YOETHF
    1616IMPLICIT NONE
    17 
    18 !=============================================
    19     INCLUDE "YOETHF.h"
    20 
    2117
    2218      CONTAINS

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

    r5134 r5143  
    2222      USE lmdz_thermcell_main, ONLY: thermcell_tke_transport
    2323      USE lmdz_alpale
     24      USE lmdz_YOETHF
     25      USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    2426
    2527      IMPLICIT NONE
    … …  
    4042
    4143      INCLUDE "YOMCST.h"
    42       INCLUDE "YOETHF.h"
    43       INCLUDE "FCTTRE.h"
    4444
    4545!   arguments:

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

    r5133 r5143  
    718718
    719719    USE dimphy
     720    USE lmdz_YOETHF
     721    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     722
    720723    IMPLICIT NONE
    721724
    … …  
    745748
    746749    include "YOMCST.h"
    747     include "YOETHF.h"
    748     include "FCTTRE.h"
    749750
    750751    ! arguments:
    … …  
    23132314
    23142315    USE dimphy
     2316    USE lmdz_YOETHF
     2317    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     2318
    23152319    IMPLICIT NONE
    23162320
    … …  
    23402344
    23412345    include "YOMCST.h"
    2342     include "YOETHF.h"
    2343     include "FCTTRE.h"
    23442346
    23452347    ! arguments:

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

    r5119 r5143  
    33
    44SUBROUTINE thermcell_qsat(klon,active,pplev,ztemp,zqta,zqsat)
     5  USE lmdz_YOETHF
     6  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    57IMPLICIT NONE
    68
    79  INCLUDE "YOMCST.h"
    8   INCLUDE "YOETHF.h"
    9   INCLUDE "FCTTRE.h"
    10 
    1110
    1211!====================================================================

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

    r5105 r5143  
    1 
    21! $Header$
    32
    43! ======================================================================
    54SUBROUTINE nonlocal(knon, paprs, pplay, tsol, beta, u, v, t, q, cd_h, cd_m, &
    6     pcfh, pcfm, cgh, cgq)
     5        pcfh, pcfm, cgh, cgq)
    76  USE dimphy
     7  USE lmdz_YOETHF
     8  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     9
    810  IMPLICIT NONE
    911  ! ======================================================================
    … …  
    2729  REAL tsol(klon) ! temperature du sol (K)
    2830  REAL beta(klon) ! efficacite d'evaporation (entre 0 et 1)
    29   REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
     31  REAL paprs(klon, klev + 1) ! pression a inter-couche (Pa)
    3032  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
    3133  REAL u(klon, klev) ! vitesse U (m/s)
    … …  
    3840  INTEGER isommet
    3941  REAL vk
    40   PARAMETER (vk=0.40)
     42  PARAMETER (vk = 0.40)
    4143  REAL ricr
    42   PARAMETER (ricr=0.4)
     44  PARAMETER (ricr = 0.4)
    4345  REAL fak
    44   PARAMETER (fak=8.5)
     46  PARAMETER (fak = 8.5)
    4547  REAL fakn
    46   PARAMETER (fakn=7.2)
     48  PARAMETER (fakn = 7.2)
    4749  REAL onet
    48   PARAMETER (onet=1.0/3.0)
     50  PARAMETER (onet = 1.0 / 3.0)
    4951  REAL t_coup
    50   PARAMETER (t_coup=273.15)
     52  PARAMETER (t_coup = 273.15)
    5153  REAL zkmin
    52   PARAMETER (zkmin=0.01)
     54  PARAMETER (zkmin = 0.01)
    5355  REAL betam
    54   PARAMETER (betam=15.0)
     56  PARAMETER (betam = 15.0)
    5557  REAL betah
    56   PARAMETER (betah=15.0)
     58  PARAMETER (betah = 15.0)
    5759  REAL betas
    58   PARAMETER (betas=5.0)
     60  PARAMETER (betas = 5.0)
    5961  REAL sffrac
    60   PARAMETER (sffrac=0.1)
     62  PARAMETER (sffrac = 0.1)
    6163  REAL binm
    62   PARAMETER (binm=betam*sffrac)
     64  PARAMETER (binm = betam * sffrac)
    6365  REAL binh
    64   PARAMETER (binh=betah*sffrac)
     66  PARAMETER (binh = betah * sffrac)
    6567  REAL ccon
    66   PARAMETER (ccon=fak*sffrac*vk)
     68  PARAMETER (ccon = fak * sffrac * vk)
    6769
    6870  REAL z(klon, klev)
    … …  
    107109  REAL fac, pblmin, zmzp, term
    108110
    109   include "YOETHF.h"
    110   include "FCTTRE.h"
    111 
    112111  ! Initialisation
    113112
    … …  
    131130
    132131  DO i = 1, knon
    133     z(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i,1)))*(paprs(i,1)-pplay(i,1) &
    134       )/rg
     132    z(i, 1) = rd * t(i, 1) / (0.5 * (paprs(i, 1) + pplay(i, 1))) * (paprs(i, 1) - pplay(i, 1) &
     133            ) / rg
    135134  END DO
    136135  DO k = 2, klev
    137136    DO i = 1, knon
    138       z(i, k) = z(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1 &
    139         )-pplay(i,k))/rg
     137      z(i, k) = z(i, k - 1) + rd * 0.5 * (t(i, k - 1) + t(i, k)) / paprs(i, k) * (pplay(i, k - 1 &
     138              ) - pplay(i, k)) / rg
    140139    END DO
    141140  END DO
    … …  
    143142  DO i = 1, knon
    144143    IF (thermcep) THEN
    145       zdelta = max(0., sign(1.,rtt-tsol(i)))
    146       zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
    147       zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,1))
    148       zxqs = r2es*foeew(tsol(i), zdelta)/paprs(i, 1)
     144      zdelta = max(0., sign(1., rtt - tsol(i)))
     145      zcvm5 = r5les * rlvtt * (1. - zdelta) + r5ies * rlstt * zdelta
     146      zcvm5 = zcvm5 / rcpd / (1.0 + rvtmp2 * q(i, 1))
     147      zxqs = r2es * foeew(tsol(i), zdelta) / paprs(i, 1)
    149148      zxqs = min(0.5, zxqs)
    150       zcor = 1./(1.-retv*zxqs)
    151       zxqs = zxqs*zcor
     149      zcor = 1. / (1. - retv * zxqs)
     150      zxqs = zxqs * zcor
    152151    ELSE
    153152      IF (tsol(i)<t_coup) THEN
    154         zxqs = qsats(tsol(i))/paprs(i, 1)
     153        zxqs = qsats(tsol(i)) / paprs(i, 1)
    155154      ELSE
    156         zxqs = qsatl(tsol(i))/paprs(i, 1)
     155        zxqs = qsatl(tsol(i)) / paprs(i, 1)
    157156      END IF
    158157    END IF
    159158    zx_alf1 = 1.0
    160159    zx_alf2 = 1.0 - zx_alf1
    161     zxt = (t(i,1)+z(i,1)*rg/rcpd/(1.+rvtmp2*q(i,1)))*(1.+retv*q(i,1))*zx_alf1 &
    162       + (t(i,2)+z(i,2)*rg/rcpd/(1.+rvtmp2*q(i,2)))*(1.+retv*q(i,2))*zx_alf2
    163     zxu = u(i, 1)*zx_alf1 + u(i, 2)*zx_alf2
    164     zxv = v(i, 1)*zx_alf1 + v(i, 2)*zx_alf2
    165     zxq = q(i, 1)*zx_alf1 + q(i, 2)*zx_alf2
    166     zxmod = 1.0 + sqrt(zxu**2+zxv**2)
    167     khfs(i) = (tsol(i)*(1.+retv*q(i,1))-zxt)*zxmod*cd_h(i)
    168     kqfs(i) = (zxqs-zxq)*zxmod*cd_h(i)*beta(i)
    169     heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
    170     taux = zxu*zxmod*cd_m(i)
    171     tauy = zxv*zxmod*cd_m(i)
    172     ustar(i) = sqrt(taux**2+tauy**2)
     160    zxt = (t(i, 1) + z(i, 1) * rg / rcpd / (1. + rvtmp2 * q(i, 1))) * (1. + retv * q(i, 1)) * zx_alf1 &
     161            + (t(i, 2) + z(i, 2) * rg / rcpd / (1. + rvtmp2 * q(i, 2))) * (1. + retv * q(i, 2)) * zx_alf2
     162    zxu = u(i, 1) * zx_alf1 + u(i, 2) * zx_alf2
     163    zxv = v(i, 1) * zx_alf1 + v(i, 2) * zx_alf2
     164    zxq = q(i, 1) * zx_alf1 + q(i, 2) * zx_alf2
     165    zxmod = 1.0 + sqrt(zxu**2 + zxv**2)
     166    khfs(i) = (tsol(i) * (1. + retv * q(i, 1)) - zxt) * zxmod * cd_h(i)
     167    kqfs(i) = (zxqs - zxq) * zxmod * cd_h(i) * beta(i)
     168    heatv(i) = khfs(i) + 0.61 * zxt * kqfs(i)
     169    taux = zxu * zxmod * cd_m(i)
     170    tauy = zxv * zxmod * cd_m(i)
     171    ustar(i) = sqrt(taux**2 + tauy**2)
    173172    ustar(i) = max(sqrt(ustar(i)), 0.01)
    174173  END DO
    … …  
    178177    check(i) = .TRUE.
    179178    pblh(i) = z(i, 1)
    180     obklen(i) = -t(i, 1)*ustar(i)**3/(rg*vk*heatv(i))
     179    obklen(i) = -t(i, 1) * ustar(i)**3 / (rg * vk * heatv(i))
    181180  END DO
    182181
    … …  
    190189    DO i = 1, knon
    191190      IF (check(i)) THEN
    192         zdu2 = (u(i,k)-u(i,1))**2 + (v(i,k)-v(i,1))**2 + fac*ustar(i)**2
     191        zdu2 = (u(i, k) - u(i, 1))**2 + (v(i, k) - v(i, 1))**2 + fac * ustar(i)**2
    193192        zdu2 = max(zdu2, 1.0E-20)
    194         ztvd = (t(i,k)+z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
    195           k)))*(1.+retv*q(i,k))
    196         ztvu = (t(i,1)-z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
    197           1)))*(1.+retv*q(i,1))
    198         rino(i, k) = (z(i,k)-z(i,1))*rg*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
    199         IF (rino(i,k)>=ricr) THEN
    200           pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rino(i,k-1))/(rino(i, &
    201             k-1)-rino(i,k))
     193        ztvd = (t(i, k) + z(i, k) * 0.5 * rg / rcpd / (1. + rvtmp2 * q(i, &
     194                k))) * (1. + retv * q(i, k))
     195        ztvu = (t(i, 1) - z(i, k) * 0.5 * rg / rcpd / (1. + rvtmp2 * q(i, &
     196                1))) * (1. + retv * q(i, 1))
     197        rino(i, k) = (z(i, k) - z(i, 1)) * rg * (ztvd - ztvu) / (zdu2 * 0.5 * (ztvd + ztvu))
     198        IF (rino(i, k)>=ricr) THEN
     199          pblh(i) = z(i, k - 1) + (z(i, k - 1) - z(i, k)) * (ricr - rino(i, k - 1)) / (rino(i, &
     200                  k - 1) - rino(i, k))
    202201          check(i) = .FALSE.
    203202        END IF
    … …  
    232231  DO i = 1, knon
    233232    IF (check(i)) THEN
    234       phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
    235       wm(i) = ustar(i)*phiminv(i)
    236       therm(i) = heatv(i)*fak/wm(i)
     233      phiminv(i) = (1. - binm * pblh(i) / obklen(i))**onet
     234      wm(i) = ustar(i) * phiminv(i)
     235      therm(i) = heatv(i) * fak / wm(i)
    237236      rino(i, 1) = 0.0
    238237    END IF
    … …  
    245244    DO i = 1, knon
    246245      IF (check(i)) THEN
    247         zdu2 = (u(i,k)-u(i,1))**2 + (v(i,k)-v(i,1))**2 + fac*ustar(i)**2
     246        zdu2 = (u(i, k) - u(i, 1))**2 + (v(i, k) - v(i, 1))**2 + fac * ustar(i)**2
    248247        zdu2 = max(zdu2, 1.0E-20)
    249         ztvd = (t(i,k)+z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
    250           k)))*(1.+retv*q(i,k))
    251         ztvu = (t(i,1)+therm(i)-z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
    252           1)))*(1.+retv*q(i,1))
    253         rino(i, k) = (z(i,k)-z(i,1))*rg*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
    254         IF (rino(i,k)>=ricr) THEN
    255           pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rino(i,k-1))/(rino(i, &
    256             k-1)-rino(i,k))
     248        ztvd = (t(i, k) + z(i, k) * 0.5 * rg / rcpd / (1. + rvtmp2 * q(i, &
     249                k))) * (1. + retv * q(i, k))
     250        ztvu = (t(i, 1) + therm(i) - z(i, k) * 0.5 * rg / rcpd / (1. + rvtmp2 * q(i, &
     251                1))) * (1. + retv * q(i, 1))
     252        rino(i, k) = (z(i, k) - z(i, 1)) * rg * (ztvd - ztvu) / (zdu2 * 0.5 * (ztvd + ztvu))
     253        IF (rino(i, k)>=ricr) THEN
     254          pblh(i) = z(i, k - 1) + (z(i, k - 1) - z(i, k)) * (ricr - rino(i, k - 1)) / (rino(i, &
     255                  k - 1) - rino(i, k))
    257256          check(i) = .FALSE.
    258257        END IF
    … …  
    287286
    288287  DO i = 1, knon
    289     pblmin = 700.0*ustar(i)
     288    pblmin = 700.0 * ustar(i)
    290289    pblh(i) = max(pblh(i), pblmin)
    291290  END DO
    … …  
    295294  DO i = 1, knon
    296295    pblk(i) = 0.0
    297     fak1(i) = ustar(i)*pblh(i)*vk
     296    fak1(i) = ustar(i) * pblh(i) * vk
    298297
    299298    ! Do additional preparation for unstable cases only, set temperature
    … …  
    301300
    302301    IF (unstbl(i)) THEN
    303       zxt = (t(i,1)-z(i,1)*0.5*rg/rcpd/(1.+rvtmp2*q(i,1)))*(1.+retv*q(i,1))
    304       phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
    305       phihinv(i) = sqrt(1.-binh*pblh(i)/obklen(i))
    306       wm(i) = ustar(i)*phiminv(i)
    307       fak2(i) = wm(i)*pblh(i)*vk
    308       wstr(i) = (heatv(i)*rg*pblh(i)/zxt)**onet
    309       fak3(i) = fakn*wstr(i)/wm(i)
     302      zxt = (t(i, 1) - z(i, 1) * 0.5 * rg / rcpd / (1. + rvtmp2 * q(i, 1))) * (1. + retv * q(i, 1))
     303      phiminv(i) = (1. - binm * pblh(i) / obklen(i))**onet
     304      phihinv(i) = sqrt(1. - binh * pblh(i) / obklen(i))
     305      wm(i) = ustar(i) * phiminv(i)
     306      fak2(i) = wm(i) * pblh(i) * vk
     307      wstr(i) = (heatv(i) * rg * pblh(i) / zxt)**onet
     308      fak3(i) = fakn * wstr(i) / wm(i)
    310309    END IF
    311310  END DO
    … …  
    321320      unslev(i) = .FALSE.
    322321      stblev(i) = .FALSE.
    323       zm(i) = z(i, k-1)
     322      zm(i) = z(i, k - 1)
    324323      zp(i) = z(i, k)
    325324      IF (zkmin==0.0 .AND. zp(i)>pblh(i)) zp(i) = pblh(i)
    326325      IF (zm(i)<pblh(i)) THEN
    327         zmzp = 0.5*(zm(i)+zp(i))
    328         zh(i) = zmzp/pblh(i)
    329         zl(i) = zmzp/obklen(i)
     326        zmzp = 0.5 * (zm(i) + zp(i))
     327        zh(i) = zmzp / pblh(i)
     328        zl(i) = zmzp / obklen(i)
    330329        zzh(i) = 0.
    331         IF (zh(i)<=1.0) zzh(i) = (1.-zh(i))**2
     330        IF (zh(i)<=1.0) zzh(i) = (1. - zh(i))**2
    332331
    333332        ! stblev for points zm < plbh and stable and neutral
    … …  
    348347      IF (stblev(i)) THEN
    349348        IF (zl(i)<=1.) THEN
    350           pblk(i) = fak1(i)*zh(i)*zzh(i)/(1.+betas*zl(i))
     349          pblk(i) = fak1(i) * zh(i) * zzh(i) / (1. + betas * zl(i))
    351350        ELSE
    352           pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas+zl(i))
     351          pblk(i) = fak1(i) * zh(i) * zzh(i) / (betas + zl(i))
    353352        END IF
    354353        pcfm(i, k) = pblk(i)
    … …  
    376375    DO i = 1, knon
    377376      IF (unssrf(i)) THEN
    378         term = (1.-betam*zl(i))**onet
    379         pblk(i) = fak1(i)*zh(i)*zzh(i)*term
    380         pr(i) = term/sqrt(1.-betah*zl(i))
     377        term = (1. - betam * zl(i))**onet
     378        pblk(i) = fak1(i) * zh(i) * zzh(i) * term
     379        pr(i) = term / sqrt(1. - betah * zl(i))
    381380      END IF
    382381    END DO
    … …  
    386385    DO i = 1, knon
    387386      IF (unsout(i)) THEN
    388         pblk(i) = fak2(i)*zh(i)*zzh(i)
    389         cgs(i, k) = fak3(i)/(pblh(i)*wm(i))
    390         cgh(i, k) = khfs(i)*cgs(i, k)
    391         pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
    392         cgq(i, k) = kqfs(i)*cgs(i, k)
     387        pblk(i) = fak2(i) * zh(i) * zzh(i)
     388        cgs(i, k) = fak3(i) / (pblh(i) * wm(i))
     389        cgh(i, k) = khfs(i) * cgs(i, k)
     390        pr(i) = phiminv(i) / phihinv(i) + ccon * fak3(i) / fak
     391        cgq(i, k) = kqfs(i) * cgs(i, k)
    393392      END IF
    394393    END DO
    … …  
    399398      IF (unslev(i)) THEN
    400399        pcfm(i, k) = pblk(i)
    401         pcfh(i, k) = pblk(i)/pr(i)
     400        pcfh(i, k) = pblk(i) / pr(i)
    402401      END IF
    403402    END DO
    404403  END DO ! end of level loop
    405404
    406 
    407405END SUBROUTINE nonlocal

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

    r5139 r5143  
    343343SUBROUTINE diagcld2(paprs, pplay, t, q, diafra, dialiq)
    344344  USE dimphy
     345  USE lmdz_YOETHF
     346  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
     347
    345348  IMPLICIT NONE
    346349
    … …  
    374377  REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp
    375378  REAL zdelta, zcor
    376 
    377   ! Fonctions thermodynamiques:
    378   include "YOETHF.h"
    379   include "FCTTRE.h"
    380379
    381380  ! Initialisation:

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

    r5117 r5143  
    118118
    119119  USE dimphy
     120  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     121          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     122  USE lmdz_libmath, ONLY: ismax, ismin
     123
    120124  IMPLICIT NONE
    121125
    … …  
    148152  ! implicit LOGICAL (l)
    149153
    150   ! method.
    151   ! -------
    152 
    153   ! externals.
    154   ! ----------
    155   INTEGER ismin, ismax
    156   EXTERNAL ismin, ismax
    157 
    158   ! reference.
    159   ! ----------
    160 
    161154  ! author.
    162155  ! -------
    … …  
    167160
    168161  include "YOMCST.h"
    169   include "YOEGWD.h"
    170162  ! -----------------------------------------------------------------------
    171163
    … …  
    385377  ! -----------------------------------------------------------------------
    386378  USE dimphy
     379  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     380          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     381
    387382  IMPLICIT NONE
    388383
    389384  include "YOMCST.h"
    390   include "YOEGWD.h"
    391385
    392386  ! -----------------------------------------------------------------------
    … …  
    820814  ! -----------------------------------------------------------------------
    821815  USE dimphy
     816  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     817          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     818
    822819  IMPLICIT NONE
    823820  include "YOMCST.h"
    824   include "YOEGWD.h"
    825821
    826822  ! -----------------------------------------------------------------------
    … …  
    942938  ! -----------------------------------------------------------------------
    943939  USE dimphy
     940  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     941          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     942
    944943  IMPLICIT NONE
    945944
    946945  include "YOMCST.h"
    947   include "YOEGWD.h"
    948946
    949947  ! -----------------------------------------------------------------------
    … …  
    12731271  USE dimphy
    12741272  USE lmdz_abort_physic, ONLY: abort_physic
     1273  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     1274          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     1275
    12751276  IMPLICIT NONE
    12761277
    12771278  include "YOMCST.h"
    1278   include "YOEGWD.h"
    12791279  ! -----------------------------------------------------------------------
    12801280
    … …  
    15151515  USE lmdz_phys_para
    15161516  USE lmdz_grid_phy
     1517  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     1518          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
    15171519  ! USE parallel
    15181520
    … …  
    15591561  ! ------------------------------------------------------------------
    15601562  IMPLICIT NONE
    1561 
    1562   ! -----------------------------------------------------------------
    1563   include "YOEGWD.h"
    1564   ! ----------------------------------------------------------------
    15651563
    15661564  INTEGER nlon, nlev, jk

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

    r5117 r5143  
    44
    55  USE dimphy
     6  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     7          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     8
    69  IMPLICIT NONE
    710  ! ======================================================================
    … …  
    6366  ! ======================================================================
    6467  include "YOMCST.h"
    65   include "YOEGWD.h"
    6668
    6769  ! ARGUMENTS
    … …  
    159161
    160162  USE dimphy
     163  USE lmdz_libmath, ONLY: ismin, ismax
     164  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     165          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     166
    161167  IMPLICIT NONE
    162168
    … …  
    222228  ! -------
    223229
    224   ! externals.
    225   ! ----------
    226   INTEGER ismin, ismax
    227   EXTERNAL ismin, ismax
    228230
    229231  ! reference.
    … …  
    238240
    239241  include "YOMCST.h"
    240   include "YOEGWD.h"
    241242
    242243  ! -----------------------------------------------------------------------
    … …  
    529530  ! -----------------------------------------------------------------------
    530531  USE dimphy
     532  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     533          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     534
    531535  IMPLICIT NONE
    532536
    533537  include "YOMCST.h"
    534   include "YOEGWD.h"
    535538
    536539  ! -----------------------------------------------------------------------
    … …  
    974977  ! -----------------------------------------------------------------------
    975978  USE dimphy
     979  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     980          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     981
    976982  IMPLICIT NONE
    977983
    978984  include "YOMCST.h"
    979   include "YOEGWD.h"
    980985
    981986  ! -----------------------------------------------------------------------
    … …  
    10871092
    10881093  USE dimphy
     1094  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     1095          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     1096
    10891097  IMPLICIT NONE
    10901098
    10911099  include "YOMCST.h"
    1092   include "YOEGWD.h"
    10931100
    10941101  ! -----------------------------------------------------------------------
    … …  
    12571264
    12581265  USE dimphy
     1266  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     1267          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     1268
    12591269  IMPLICIT NONE
    12601270  ! ======================================================================
    … …  
    13171327
    13181328  include "YOMCST.h"
    1319   include "YOEGWD.h"
    13201329
    13211330  ! ARGUMENTS
    … …  
    14701479  USE dimphy
    14711480  USE lmdz_abort_physic, ONLY: abort_physic
     1481  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     1482          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     1483
    14721484  IMPLICIT NONE
    14731485
    14741486  include "YOMCST.h"
    1475   include "YOEGWD.h"
    14761487  ! -----------------------------------------------------------------------
    14771488
    … …  
    17771788  USE lmdz_geometry
    17781789  USE lmdz_abort_physic, ONLY: abort_physic
     1790  USE lmdz_YOEGWD, ONLY: GFRCRIT, GKWAKE, GRCRIT, GVCRIT, GKDRAG, GKLIFT, GHMAX, GRAHILO, GSIGCR, NKTOPG, NSTRA, GSSEC, GTSEC, GVSEC, &
     1791          GWD_RANDO_RUWMAX, gwd_rando_sat, GWD_FRONT_RUWMAX, gwd_front_sat
     1792
    17791793  IMPLICIT NONE
    1780 
    1781   ! -----------------------------------------------------------------
    1782   include "YOEGWD.h"
    1783   ! ----------------------------------------------------------------
    17841794
    17851795  ! ARGUMENTS

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

    r5142 r5143  
    418418  USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree
    419419  USE lmdz_dimpft, ONLY: nvm_lmdz
     420  USE lmdz_YOETHF
     421  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    420422
    421423    IMPLICIT NONE
    … …  
    423425    INCLUDE "dimsoil.h"
    424426    INCLUDE "YOMCST.h"
    425     INCLUDE "YOETHF.h"
    426     INCLUDE "FCTTRE.h"
    427427
    428428    !****************************************************************************************

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

    r5142 r5143  
    356356    USE lmdz_conema3
    357357    USE lmdz_dimpft, ONLY: nvm_lmdz
     358    USE lmdz_YOETHF
     359    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    358360
    359361    IMPLICIT NONE
    … …  
    11541156
    11551157    include "YOMCST.h"
    1156     include "YOETHF.h"
    1157     include "FCTTRE.h"
    11581158
    11591159    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

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

    r5137 r5143  
    5252    USE lmdz_writefield_phy
    5353    USE lmdz_clesphys
     54    USE lmdz_YOETHF
    5455
    5556#ifdef REPROBUS
    … …  
    191192    ! DECLARATIONS
    192193    ! ==============
    193     include "YOETHF.h"
    194194    include "YOMCST.h"
    195195

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

    r5134 r5143  
    1   SUBROUTINE reevap(klon,klev,iflag_ice_thermo,t_seri,q_seri,ql_seri,qs_seri, &
    2            d_t_eva,d_q_eva,d_ql_eva,d_qs_eva)
     1SUBROUTINE reevap(klon, klev, iflag_ice_thermo, t_seri, q_seri, ql_seri, qs_seri, &
     2        d_t_eva, d_q_eva, d_ql_eva, d_qs_eva)
    33
    4     ! flag to include modifications to ensure energy conservation (if flag >0)
    5     USE add_phys_tend_mod, ONLY: fl_cor_ebil
    6    
    7     IMPLICIT NONE
    8     !>======================================================================
     4  ! flag to include modifications to ensure energy conservation (if flag >0)
     5  USE add_phys_tend_mod, ONLY: fl_cor_ebil
     6  USE lmdz_YOETHF
     7  USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    98
    10     INTEGER klon,klev,iflag_ice_thermo
    11     REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri,q_seri,ql_seri,qs_seri
    12     REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_t_eva,d_q_eva,d_ql_eva,d_qs_eva
     9  IMPLICIT NONE
     10  !>======================================================================
    1311
    14     REAL za,zb,zdelta,zlvdcp,zlsdcp
    15     INTEGER i,k
     12  INTEGER klon, klev, iflag_ice_thermo
     13  REAL, DIMENSION(klon, klev), INTENT(IN) :: t_seri, q_seri, ql_seri, qs_seri
     14  REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_t_eva, d_q_eva, d_ql_eva, d_qs_eva
    1615
    17     !--------Stochastic Boundary Layer Triggering: ALE_BL--------
    18     !---Propri\'et\'es du thermiques au LCL
    19     include "YOMCST.h"
    20     include "YOETHF.h"
    21     include "FCTTRE.h"
    22     !IM 100106 BEG : pouvoir sortir les ctes de la physique
     16  REAL za, zb, zdelta, zlvdcp, zlsdcp
     17  INTEGER i, k
    2318
    24     ! Re-evaporer l'eau liquide nuageuse
     19  !--------Stochastic Boundary Layer Triggering: ALE_BL--------
     20  !---Propri\'et\'es du thermiques au LCL
     21  include "YOMCST.h"
     22  !IM 100106 BEG : pouvoir sortir les ctes de la physique
    2523
    26 !print *,'rrevap ; fl_cor_ebil:',fl_cor_ebil,' iflag_ice_thermo:',iflag_ice_thermo,' RVTMP2',RVTMP2
    27     DO k = 1, klev  ! re-evaporation de l'eau liquide nuageuse
    28        DO i = 1, klon
    29         IF (fl_cor_ebil > 0) THEN
    30           zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*(q_seri(i,k)+ql_seri(i,k)+qs_seri(i,k)))
    31           zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*(q_seri(i,k)+ql_seri(i,k)+qs_seri(i,k)))
    32         else
    33           zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
    34           !jyg<
    35           !  Attention : Arnaud a propose des formules completement differentes
    36           !                  A verifier !!!
    37           zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
    38         end if
    39           IF (iflag_ice_thermo == 0) THEN
    40              zlsdcp=zlvdcp
    41           ENDIF
    42           !>jyg
     24  ! Re-evaporer l'eau liquide nuageuse
    4325
    44           IF (iflag_ice_thermo==0) THEN
    45              !pas necessaire a priori
     26  !print *,'rrevap ; fl_cor_ebil:',fl_cor_ebil,' iflag_ice_thermo:',iflag_ice_thermo,' RVTMP2',RVTMP2
     27  DO k = 1, klev  ! re-evaporation de l'eau liquide nuageuse
     28    DO i = 1, klon
     29      IF (fl_cor_ebil > 0) THEN
     30        zlvdcp = RLVTT / RCPD / (1.0 + RVTMP2 * (q_seri(i, k) + ql_seri(i, k) + qs_seri(i, k)))
     31        zlsdcp = RLSTT / RCPD / (1.0 + RVTMP2 * (q_seri(i, k) + ql_seri(i, k) + qs_seri(i, k)))
     32      else
     33        zlvdcp = RLVTT / RCPD / (1.0 + RVTMP2 * q_seri(i, k))
     34        !jyg<
     35        !  Attention : Arnaud a propose des formules completement differentes
     36        !                  A verifier !!!
     37        zlsdcp = RLSTT / RCPD / (1.0 + RVTMP2 * q_seri(i, k))
     38      end if
     39      IF (iflag_ice_thermo == 0) THEN
     40        zlsdcp = zlvdcp
     41      ENDIF
     42      !>jyg
    4643
    47              zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
    48   zdelta = 0.
    49              zb = MAX(0.0,ql_seri(i,k))
    50              za = - MAX(0.0,ql_seri(i,k)) &
    51                   * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
    52              d_t_eva(i,k) = za
    53              d_q_eva(i,k) = zb
    54              d_ql_eva(i,k) = -ql_seri(i,k)
    55              d_qs_eva(i,k) = 0.
     44      IF (iflag_ice_thermo==0) THEN
     45        !pas necessaire a priori
    5646
    57           ELSE
     47        zdelta = MAX(0., SIGN(1., RTT - t_seri(i, k)))
     48        zdelta = 0.
     49        zb = MAX(0.0, ql_seri(i, k))
     50        za = - MAX(0.0, ql_seri(i, k)) &
     51                * (zlvdcp * (1. - zdelta) + zlsdcp * zdelta)
     52        d_t_eva(i, k) = za
     53        d_q_eva(i, k) = zb
     54        d_ql_eva(i, k) = -ql_seri(i, k)
     55        d_qs_eva(i, k) = 0.
    5856
    59              !CR: on r\'e-\'evapore eau liquide et glace
     57      ELSE
    6058
    61              !        zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
    62              !        zb = MAX(0.0,ql_seri(i,k))
    63              !        za = - MAX(0.0,ql_seri(i,k)) &
    64              !             * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
    65              zb = MAX(0.0,ql_seri(i,k)+qs_seri(i,k))
    66              za = - MAX(0.0,ql_seri(i,k))*zlvdcp &
    67                   - MAX(0.0,qs_seri(i,k))*zlsdcp
    68              d_t_eva(i,k) = za
    69              d_q_eva(i,k) = zb
    70              d_ql_eva(i,k) = -ql_seri(i,k)
    71              d_qs_eva(i,k) = -qs_seri(i,k)
    72           ENDIF
     59        !CR: on r\'e-\'evapore eau liquide et glace
    7360
    74        ENDDO
     61        !        zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
     62        !        zb = MAX(0.0,ql_seri(i,k))
     63        !        za = - MAX(0.0,ql_seri(i,k)) &
     64        !             * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
     65        zb = MAX(0.0, ql_seri(i, k) + qs_seri(i, k))
     66        za = - MAX(0.0, ql_seri(i, k)) * zlvdcp &
     67                - MAX(0.0, qs_seri(i, k)) * zlsdcp
     68        d_t_eva(i, k) = za
     69        d_q_eva(i, k) = zb
     70        d_ql_eva(i, k) = -ql_seri(i, k)
     71        d_qs_eva(i, k) = -qs_seri(i, k)
     72      ENDIF
     73
    7574    ENDDO
    76 
    77 
     75  ENDDO
    7876
    7977END SUBROUTINE reevap

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

    r5139 r5143  
    1 
    21MODULE stdlevvar_mod
    32
    4 ! This module contains main procedures for calculation
    5 ! of temperature, specific humidity and wind at a reference level
     3  ! This module contains main procedures for calculation
     4  ! of temperature, specific humidity and wind at a reference level
    65
    76  USE cdrag_mod
    … …  
    1211CONTAINS
    1312
    14 !****************************************************************************************
    15 
    16 !r original routine svn3623
    17 
    18       SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, &
    19                            u1, v1, t1, q1, z1, &
    20                            ts1, qsurf, z0m, z0h, psol, pat1, &
    21                            t_2m, q_2m, t_10m, q_10m, u_10m, ustar, s_pblh, prain, tsol)
    22         USE lmdz_flux_arp, ONLY: fsens, flat, betaevap, ust, tg, ok_flux_surf, ok_prescr_ust, ok_prescr_beta, ok_forc_tsurf
    23 
    24       IMPLICIT NONE
    25 !-------------------------------------------------------------------------
    26 
    27 ! Objet : calcul de la temperature et l'humidite relative a 2m et du
    28 !         module du vent a 10m a partir des relations de Dyer-Businger et
    29 !         des equations de Louis.
    30 
    31 ! Reference : Hess, Colman et McAvaney (1995)       
    32 
    33 ! I. Musat, 01.07.2002
    34 
    35 !AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
    36 
    37 !-------------------------------------------------------------------------
    38 
    39 ! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
    40 ! knon----input-I- nombre de points pour un type de surface
    41 ! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
    42 ! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
    43 ! u1------input-R- vent zonal au 1er niveau du modele
    44 ! v1------input-R- vent meridien au 1er niveau du modele
    45 ! t1------input-R- temperature de l'air au 1er niveau du modele
    46 ! q1------input-R- humidite relative au 1er niveau du modele
    47 ! z1------input-R- geopotentiel au 1er niveau du modele
    48 ! ts1-----input-R- temperature de l'air a la surface
    49 ! qsurf---input-R- humidite relative a la surface
    50 ! z0m, z0h---input-R- rugosite
    51 ! psol----input-R- pression au sol
    52 ! pat1----input-R- pression au 1er niveau du modele
    53 
    54 ! t_2m---output-R- temperature de l'air a 2m
    55 ! q_2m---output-R- humidite relative a 2m
    56 ! u_10m--output-R- vitesse du vent a 10m
    57 !AM
    58 ! t_10m--output-R- temperature de l'air a 10m
    59 ! q_10m--output-R- humidite specifique a 10m
    60 ! ustar--output-R- u*
    61 
    62       INTEGER, INTENT(IN) :: klon, knon, nsrf
    63       LOGICAL, INTENT(IN) :: zxli
    64       REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, t1, q1, z1, ts1
    65       REAL, DIMENSION(klon), INTENT(IN) :: qsurf
    66       REAL, DIMENSION(klon), INTENT(INOUT) :: z0m, z0h
    67       REAL, DIMENSION(klon), INTENT(IN) :: psol, pat1
    68 
    69       REAL, DIMENSION(klon), INTENT(OUT) :: t_2m, q_2m, ustar
    70       REAL, DIMENSION(klon), INTENT(OUT) :: u_10m, t_10m, q_10m
    71       REAL, DIMENSION(klon), INTENT(INOUT) :: s_pblh
    72       REAL, DIMENSION(klon), INTENT(IN) :: prain
    73       REAL, DIMENSION(klon), INTENT(IN) :: tsol
    74 !-------------------------------------------------------------------------
    75       include "YOMCST.h"
    76 !IM PLUS
    77       include "YOETHF.h"
    78 
    79 ! Quelques constantes et options:
    80 
    81 ! RKAR : constante de von Karman
    82       REAL, PARAMETER :: RKAR=0.40
    83 ! niter : nombre iterations calcul "corrector"
    84 !     INTEGER, parameter :: niter=6, ncon=niter-1
    85       INTEGER, parameter :: niter=2, ncon=niter-1
    86 
    87 ! Variables locales
    88       INTEGER :: i, n
    89       REAL :: zref
    90       REAL, DIMENSION(klon) :: speed
    91 ! tpot : temperature potentielle
    92       REAL, DIMENSION(klon) :: tpot
    93       REAL, DIMENSION(klon) :: zri1, cdran
    94       REAL, DIMENSION(klon) :: cdram, cdrah
    95 ! ri1 : nb. de Richardson entre la surface --> la 1ere couche
    96       REAL, DIMENSION(klon) :: ri1
    97       REAL, DIMENSION(klon) :: testar, qstar
    98       REAL, DIMENSION(klon) :: zdte, zdq
    99 ! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney
    100       DOUBLE PRECISION, DIMENSION(klon) :: lmon
    101       DOUBLE PRECISION, parameter :: eps=1.0D-20
    102       REAL, DIMENSION(klon) :: delu, delte, delq
    103       REAL, DIMENSION(klon) :: u_zref, te_zref, q_zref
    104       REAL, DIMENSION(klon) :: temp, pref
    105       LOGICAL :: okri
    106       REAL, DIMENSION(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
    107 !convertgence
    108       REAL, DIMENSION(klon) :: te_zref_con, q_zref_con
    109       REAL, DIMENSION(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
    110       REAL, DIMENSION(klon) :: ok_pred, ok_corr, zri_zero
    111 !     REAL, DIMENSION(klon) :: conv_te, conv_q
    112 !-------------------------------------------------------------------------
    113       DO i=1, knon
    114        speed(i)=SQRT(u1(i)**2+v1(i)**2)
    115        ri1(i) = 0.0
     13  !****************************************************************************************
     14
     15  !r original routine svn3623
     16
     17  SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, &
     18          u1, v1, t1, q1, z1, &
     19          ts1, qsurf, z0m, z0h, psol, pat1, &
     20          t_2m, q_2m, t_10m, q_10m, u_10m, ustar, s_pblh, prain, tsol)
     21    USE lmdz_flux_arp, ONLY: fsens, flat, betaevap, ust, tg, ok_flux_surf, ok_prescr_ust, ok_prescr_beta, ok_forc_tsurf
     22    USE lmdz_YOETHF
     23
     24    IMPLICIT NONE
     25    !-------------------------------------------------------------------------
     26
     27    ! Objet : calcul de la temperature et l'humidite relative a 2m et du
     28    !         module du vent a 10m a partir des relations de Dyer-Businger et
     29    !         des equations de Louis.
     30
     31    ! Reference : Hess, Colman et McAvaney (1995)
     32
     33    ! I. Musat, 01.07.2002
     34
     35    !AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
     36
     37    !-------------------------------------------------------------------------
     38
     39    ! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
     40    ! knon----input-I- nombre de points pour un type de surface
     41    ! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
     42    ! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
     43    ! u1------input-R- vent zonal au 1er niveau du modele
     44    ! v1------input-R- vent meridien au 1er niveau du modele
     45    ! t1------input-R- temperature de l'air au 1er niveau du modele
     46    ! q1------input-R- humidite relative au 1er niveau du modele
     47    ! z1------input-R- geopotentiel au 1er niveau du modele
     48    ! ts1-----input-R- temperature de l'air a la surface
     49    ! qsurf---input-R- humidite relative a la surface
     50    ! z0m, z0h---input-R- rugosite
     51    ! psol----input-R- pression au sol
     52    ! pat1----input-R- pression au 1er niveau du modele
     53
     54    ! t_2m---output-R- temperature de l'air a 2m
     55    ! q_2m---output-R- humidite relative a 2m
     56    ! u_10m--output-R- vitesse du vent a 10m
     57    !AM
     58    ! t_10m--output-R- temperature de l'air a 10m
     59    ! q_10m--output-R- humidite specifique a 10m
     60    ! ustar--output-R- u*
     61
     62    INTEGER, INTENT(IN) :: klon, knon, nsrf
     63    LOGICAL, INTENT(IN) :: zxli
     64    REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, t1, q1, z1, ts1
     65    REAL, DIMENSION(klon), INTENT(IN) :: qsurf
     66    REAL, DIMENSION(klon), INTENT(INOUT) :: z0m, z0h
     67    REAL, DIMENSION(klon), INTENT(IN) :: psol, pat1
     68
     69    REAL, DIMENSION(klon), INTENT(OUT) :: t_2m, q_2m, ustar
     70    REAL, DIMENSION(klon), INTENT(OUT) :: u_10m, t_10m, q_10m
     71    REAL, DIMENSION(klon), INTENT(INOUT) :: s_pblh
     72    REAL, DIMENSION(klon), INTENT(IN) :: prain
     73    REAL, DIMENSION(klon), INTENT(IN) :: tsol
     74    !-------------------------------------------------------------------------
     75    include "YOMCST.h"
     76
     77    ! Quelques constantes et options:
     78
     79    ! RKAR : constante de von Karman
     80    REAL, PARAMETER :: RKAR = 0.40
     81    ! niter : nombre iterations calcul "corrector"
     82    !     INTEGER, parameter :: niter=6, ncon=niter-1
     83    INTEGER, parameter :: niter = 2, ncon = niter - 1
     84
     85    ! Variables locales
     86    INTEGER :: i, n
     87    REAL :: zref
     88    REAL, DIMENSION(klon) :: speed
     89    ! tpot : temperature potentielle
     90    REAL, DIMENSION(klon) :: tpot
     91    REAL, DIMENSION(klon) :: zri1, cdran
     92    REAL, DIMENSION(klon) :: cdram, cdrah
     93    ! ri1 : nb. de Richardson entre la surface --> la 1ere couche
     94    REAL, DIMENSION(klon) :: ri1
     95    REAL, DIMENSION(klon) :: testar, qstar
     96    REAL, DIMENSION(klon) :: zdte, zdq
     97    ! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney
     98    DOUBLE PRECISION, DIMENSION(klon) :: lmon
     99    DOUBLE PRECISION, parameter :: eps = 1.0D-20
     100    REAL, DIMENSION(klon) :: delu, delte, delq
     101    REAL, DIMENSION(klon) :: u_zref, te_zref, q_zref
     102    REAL, DIMENSION(klon) :: temp, pref
     103    LOGICAL :: okri
     104    REAL, DIMENSION(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
     105    !convertgence
     106    REAL, DIMENSION(klon) :: te_zref_con, q_zref_con
     107    REAL, DIMENSION(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
     108    REAL, DIMENSION(klon) :: ok_pred, ok_corr, zri_zero
     109    !     REAL, DIMENSION(klon) :: conv_te, conv_q
     110    !-------------------------------------------------------------------------
     111    DO i = 1, knon
     112      speed(i) = SQRT(u1(i)**2 + v1(i)**2)
     113      ri1(i) = 0.0
     114    ENDDO
     115
     116    okri = .FALSE.
     117    !      CALL coefcdrag(klon, knon, nsrf, zxli, &
     118    ! &                   speed, t1, q1, z1, psol, &
     119    ! &                   ts1, qsurf, rugos, okri, ri1,  &
     120    ! &                   cdram, cdrah, cdran, zri1, pref)
     121    ! Fuxing WANG, 04/03/2015, replace the coefcdrag by the merged version: cdrag
     122
     123    CALL cdrag(knon, nsrf, &
     124            speed, t1, q1, z1, &
     125            psol, s_pblh, ts1, qsurf, z0m, z0h, &
     126            zri_zero, 0, &
     127            cdram, cdrah, zri1, pref, prain, tsol, pat1)
     128
     129    ! --- special Dice: on force cdragm ( a defaut de forcer ustar) MPL 05082013
     130    IF (ok_prescr_ust) THEN
     131      DO i = 1, knon
     132        print *, 'cdram avant=', cdram(i)
     133        cdram(i) = ust * ust / speed(i) / speed(i)
     134        print *, 'cdram ust speed apres=', cdram(i), ust, speed
    116135      ENDDO
    117 
    118       okri=.FALSE.
    119 !      CALL coefcdrag(klon, knon, nsrf, zxli, &
    120 ! &                   speed, t1, q1, z1, psol, &
    121 ! &                   ts1, qsurf, rugos, okri, ri1,  &         
    122 ! &                   cdram, cdrah, cdran, zri1, pref)           
    123 ! Fuxing WANG, 04/03/2015, replace the coefcdrag by the merged version: cdrag
    124 
    125       CALL cdrag(knon, nsrf, &
    126                      speed, t1, q1, z1, &
    127                      psol, s_pblh, ts1, qsurf, z0m, z0h, &
    128                      zri_zero, 0, &
    129                      cdram, cdrah, zri1, pref, prain, tsol, pat1)
    130 
    131 ! --- special Dice: on force cdragm ( a defaut de forcer ustar) MPL 05082013
    132      IF (ok_prescr_ust) THEN
    133       DO i = 1, knon
    134        print *,'cdram avant=',cdram(i)
    135        cdram(i) = ust*ust/speed(i)/speed(i)
    136        print *,'cdram ust speed apres=',cdram(i),ust,speed
    137       ENDDO
    138      ENDIF
    139 
    140 !---------Star variables----------------------------------------------------
    141 
    142       DO i = 1, knon
    143         ri1(i) = zri1(i)
    144         tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA
    145         ustar(i) = sqrt(cdram(i) * speed(i) * speed(i))
    146         zdte(i) = tpot(i) - ts1(i)
    147         zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0)
    148 
    149 
    150 !IM BUG BUG BUG       zdte(i) = max(zdte(i),1.e-10)
    151         zdte(i) = sign(max(abs(zdte(i)),1.e-10),zdte(i))
    152 
    153         testar(i) = (cdrah(i) * zdte(i) * speed(i))/ustar(i)
    154         qstar(i) = (cdrah(i) * zdq(i) * speed(i))/ustar(i)
    155         lmon(i) = (ustar(i) * ustar(i) * tpot(i))/ &
    156                   (RKAR * RG * testar(i))
    157       ENDDO
    158 
    159 !----------First aproximation of variables at zref --------------------------
    160       zref = 2.0
    161       CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
    162                    ts1, qsurf, z0m, lmon, &
    163                    ustar, testar, qstar, zref, &
    164                    delu, delte, delq)
     136    ENDIF
     137
     138    !---------Star variables----------------------------------------------------
     139
     140    DO i = 1, knon
     141      ri1(i) = zri1(i)
     142      tpot(i) = t1(i) * (psol(i) / pat1(i))**RKAPPA
     143      ustar(i) = sqrt(cdram(i) * speed(i) * speed(i))
     144      zdte(i) = tpot(i) - ts1(i)
     145      zdq(i) = max(q1(i), 0.0) - max(qsurf(i), 0.0)
     146
     147
     148      !IM BUG BUG BUG       zdte(i) = max(zdte(i),1.e-10)
     149      zdte(i) = sign(max(abs(zdte(i)), 1.e-10), zdte(i))
     150
     151      testar(i) = (cdrah(i) * zdte(i) * speed(i)) / ustar(i)
     152      qstar(i) = (cdrah(i) * zdq(i) * speed(i)) / ustar(i)
     153      lmon(i) = (ustar(i) * ustar(i) * tpot(i)) / &
     154              (RKAR * RG * testar(i))
     155    ENDDO
     156
     157    !----------First aproximation of variables at zref --------------------------
     158    zref = 2.0
     159    CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
     160            ts1, qsurf, z0m, lmon, &
     161            ustar, testar, qstar, zref, &
     162            delu, delte, delq)
     163
     164    DO i = 1, knon
     165      u_zref(i) = delu(i)
     166      q_zref(i) = max(qsurf(i), 0.0) + delq(i)
     167      te_zref(i) = ts1(i) + delte(i)
     168      temp(i) = te_zref(i) * (psol(i) / pat1(i))**(-RKAPPA)
     169      q_zref_p(i) = q_zref(i)
     170      !       te_zref_p(i) = te_zref(i)
     171      temp_p(i) = temp(i)
     172    ENDDO
     173
     174    ! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995
     175
     176    DO n = 1, niter
     177
     178      okri = .TRUE.
     179      CALL screenc(klon, knon, nsrf, zxli, &
     180              u_zref, temp, q_zref, zref, &
     181              ts1, qsurf, z0m, z0h, psol, &
     182              ustar, testar, qstar, okri, ri1, &
     183              pref, delu, delte, delq, s_pblh, prain, tsol, pat1)
    165184
    166185      DO i = 1, knon
    167186        u_zref(i) = delu(i)
    168         q_zref(i) = max(qsurf(i),0.0) + delq(i)
    169         te_zref(i) = ts1(i) + delte(i)
    170         temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
    171         q_zref_p(i) = q_zref(i)
    172 !       te_zref_p(i) = te_zref(i)
    173         temp_p(i) = temp(i)
    174       ENDDO
    175 
    176 ! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995
    177 
    178       DO n = 1, niter
    179 
    180         okri=.TRUE.
    181         CALL screenc(klon, knon, nsrf, zxli, &
    182                      u_zref, temp, q_zref, zref, &
    183                      ts1, qsurf, z0m, z0h, psol, &
    184                      ustar, testar, qstar, okri, ri1, &
    185                      pref, delu, delte, delq, s_pblh ,prain, tsol, pat1)
    186 
    187         DO i = 1, knon
    188           u_zref(i) = delu(i)
    189           q_zref(i) = delq(i) + max(qsurf(i),0.0)
    190           te_zref(i) = delte(i) + ts1(i)
    191 
    192 ! return to normal temperature
    193 
    194           temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
    195 !         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
    196 !                 (1 + RVTMP2 * max(q_zref(i),0.0))
    197 
    198 !IM +++
    199 !         IF(temp(i).GT.350.) THEN
    200 !           WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i)
    201 !         ENDIF
    202 !IM ---
     187        q_zref(i) = delq(i) + max(qsurf(i), 0.0)
     188        te_zref(i) = delte(i) + ts1(i)
     189
     190        ! return to normal temperature
     191
     192        temp(i) = te_zref(i) * (psol(i) / pref(i))**(-RKAPPA)
     193        !         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
     194        !                 (1 + RVTMP2 * max(q_zref(i),0.0))
     195
     196        !IM +++
     197        !         IF(temp(i).GT.350.) THEN
     198        !           WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i)
     199        !         ENDIF
     200        !IM ---
    203201
    204202        IF(n==ncon) THEN
    205203          te_zref_con(i) = te_zref(i)
    206204          q_zref_con(i) = q_zref(i)
    207         ENDIF
    208 
    209         ENDDO
    210 
    211       ENDDO
    212 
    213 ! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref
    214 
    215 !       DO i = 1, knon
    216 !         conv_te(i) = (te_zref(i) - te_zref_con(i))/te_zref_con(i)
    217 !         conv_q(i) = (q_zref(i) - q_zref_con(i))/q_zref_con(i)
    218 !IM +++
    219 !         IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN
    220 !           PRINT*,'DIV','i=',i,te_zref_con(i),te_zref(i),conv_te(i), &
    221 !           q_zref_con(i),q_zref(i),conv_q(i)
    222 !         ENDIF
    223 !IM ---
    224 !       ENDDO
    225 
    226       DO i = 1, knon
    227         q_zref_c(i) = q_zref(i)
    228         temp_c(i) = temp(i)
    229 
    230 !       IF(zri1(i).LT.0.) THEN
    231 !         IF(nsrf.EQ.1) THEN
    232 !           ok_pred(i)=1.
    233 !           ok_corr(i)=0.
    234 !         ELSE
    235 !           ok_pred(i)=0.
    236 !           ok_corr(i)=1.
    237 !         ENDIF
    238 !       ELSE
    239 !         ok_pred(i)=0.
    240 !         ok_corr(i)=1.
    241 !       ENDIF
    242 
    243         ok_pred(i)=0.
    244         ok_corr(i)=1.
    245 
    246         t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
    247         q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
    248 !IM +++
    249 !       IF(n.EQ.niter) THEN
    250 !       IF(t_2m(i).LT.t1(i).AND.t_2m(i).LT.ts1(i)) THEN
    251 !         PRINT*,' BAD t2m LT ',i,nsrf,t_2m(i),t1(i),ts1(i)
    252 !       ELSEIF(t_2m(i).GT.t1(i).AND.t_2m(i).GT.ts1(i)) THEN
    253 !         PRINT*,' BAD t2m GT ',i,nsrf,t_2m(i),t1(i),ts1(i)
    254 !       ENDIF
    255 !       ENDIF
    256 !IM ---
     205        ENDIF
     206
    257207      ENDDO
    258208
    259 
    260 !----------First aproximation of variables at zref --------------------------
    261 
    262       zref = 10.0
    263       CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
    264                    ts1, qsurf, z0m, lmon, &
    265                    ustar, testar, qstar, zref, &
    266                    delu, delte, delq)
     209    ENDDO
     210
     211    ! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref
     212
     213    !       DO i = 1, knon
     214    !         conv_te(i) = (te_zref(i) - te_zref_con(i))/te_zref_con(i)
     215    !         conv_q(i) = (q_zref(i) - q_zref_con(i))/q_zref_con(i)
     216    !IM +++
     217    !         IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN
     218    !           PRINT*,'DIV','i=',i,te_zref_con(i),te_zref(i),conv_te(i), &
     219    !           q_zref_con(i),q_zref(i),conv_q(i)
     220    !         ENDIF
     221    !IM ---
     222    !       ENDDO
     223
     224    DO i = 1, knon
     225      q_zref_c(i) = q_zref(i)
     226      temp_c(i) = temp(i)
     227
     228      !       IF(zri1(i).LT.0.) THEN
     229      !         IF(nsrf.EQ.1) THEN
     230      !           ok_pred(i)=1.
     231      !           ok_corr(i)=0.
     232      !         ELSE
     233      !           ok_pred(i)=0.
     234      !           ok_corr(i)=1.
     235      !         ENDIF
     236      !       ELSE
     237      !         ok_pred(i)=0.
     238      !         ok_corr(i)=1.
     239      !       ENDIF
     240
     241      ok_pred(i) = 0.
     242      ok_corr(i) = 1.
     243
     244      t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
     245      q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
     246      !IM +++
     247      !       IF(n.EQ.niter) THEN
     248      !       IF(t_2m(i).LT.t1(i).AND.t_2m(i).LT.ts1(i)) THEN
     249      !         PRINT*,' BAD t2m LT ',i,nsrf,t_2m(i),t1(i),ts1(i)
     250      !       ELSEIF(t_2m(i).GT.t1(i).AND.t_2m(i).GT.ts1(i)) THEN
     251      !         PRINT*,' BAD t2m GT ',i,nsrf,t_2m(i),t1(i),ts1(i)
     252      !       ENDIF
     253      !       ENDIF
     254      !IM ---
     255    ENDDO
     256
     257
     258    !----------First aproximation of variables at zref --------------------------
     259
     260    zref = 10.0
     261    CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
     262            ts1, qsurf, z0m, lmon, &
     263            ustar, testar, qstar, zref, &
     264            delu, delte, delq)
     265
     266    DO i = 1, knon
     267      u_zref(i) = delu(i)
     268      q_zref(i) = max(qsurf(i), 0.0) + delq(i)
     269      te_zref(i) = ts1(i) + delte(i)
     270      temp(i) = te_zref(i) * (psol(i) / pat1(i))**(-RKAPPA)
     271      !       temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
     272      !                 (1 + RVTMP2 * max(q_zref(i),0.0))
     273      u_zref_p(i) = u_zref(i)
     274    ENDDO
     275
     276    ! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995
     277
     278    DO n = 1, niter
     279
     280      okri = .TRUE.
     281      CALL screenc(klon, knon, nsrf, zxli, &
     282              u_zref, temp, q_zref, zref, &
     283              ts1, qsurf, z0m, z0h, psol, &
     284              ustar, testar, qstar, okri, ri1, &
     285              pref, delu, delte, delq, s_pblh, prain, tsol, pat1)
    267286
    268287      DO i = 1, knon
    269288        u_zref(i) = delu(i)
    270         q_zref(i) = max(qsurf(i),0.0) + delq(i)
    271         te_zref(i) = ts1(i) + delte(i)
    272         temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
    273 !       temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
    274 !                 (1 + RVTMP2 * max(q_zref(i),0.0))
     289        q_zref(i) = delq(i) + max(qsurf(i), 0.0)
     290        te_zref(i) = delte(i) + ts1(i)
     291        temp(i) = te_zref(i) * (psol(i) / pref(i))**(-RKAPPA)
     292        !         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
     293        !                   (1 + RVTMP2 * max(q_zref(i),0.0))
     294      ENDDO
     295
     296    ENDDO
     297
     298    DO i = 1, knon
     299      u_zref_c(i) = u_zref(i)
     300
     301      u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
     302
     303      !AM
     304      q_zref_c(i) = q_zref(i)
     305      temp_c(i) = temp(i)
     306      t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
     307      q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
     308      !MA
     309    ENDDO
     310
     311  END SUBROUTINE stdlevvar
     312
     313  SUBROUTINE stdlevvarn(klon, knon, nsrf, zxli, &
     314          u1, v1, t1, q1, z1, &
     315          ts1, qsurf, z0m, z0h, psol, pat1, &
     316          t_2m, q_2m, t_10m, q_10m, u_10m, ustar, &
     317          n2mout)
     318
     319    USE lmdz_ioipsl_getin_p, ONLY: getin_p
     320    USE lmdz_flux_arp, ONLY: fsens, flat, betaevap, ust, tg, ok_flux_surf, ok_prescr_ust, ok_prescr_beta, ok_forc_tsurf
     321    USE lmdz_YOETHF
     322
     323    IMPLICIT NONE
     324    !-------------------------------------------------------------------------
     325
     326    ! Objet : calcul de la temperature et l'humidite relative a 2m et du
     327    !         module du vent a 10m a partir des relations de Dyer-Businger et
     328    !         des equations de Louis.
     329
     330    ! Reference : Hess, Colman et McAvaney (1995)
     331
     332    ! I. Musat, 01.07.2002
     333
     334    !AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
     335
     336    !-------------------------------------------------------------------------
     337
     338    ! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
     339    ! knon----input-I- nombre de points pour un type de surface
     340    ! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
     341    ! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
     342    ! u1------input-R- vent zonal au 1er niveau du modele
     343    ! v1------input-R- vent meridien au 1er niveau du modele
     344    ! t1------input-R- temperature de l'air au 1er niveau du modele
     345    ! q1------input-R- humidite relative au 1er niveau du modele
     346    ! z1------input-R- geopotentiel au 1er niveau du modele
     347    ! ts1-----input-R- temperature de l'air a la surface
     348    ! qsurf---input-R- humidite relative a la surface
     349    ! z0m, z0h---input-R- rugosite
     350    ! psol----input-R- pression au sol
     351    ! pat1----input-R- pression au 1er niveau du modele
     352
     353    ! t_2m---output-R- temperature de l'air a 2m
     354    ! q_2m---output-R- humidite relative a 2m
     355    ! u_2m--output-R- vitesse du vent a 2m
     356    ! u_10m--output-R- vitesse du vent a 10m
     357    ! ustar--output-R- u*
     358    !AM
     359    ! t_10m--output-R- temperature de l'air a 10m
     360    ! q_10m--output-R- humidite specifique a 10m
     361
     362    INTEGER, INTENT(IN) :: klon, knon, nsrf
     363    LOGICAL, INTENT(IN) :: zxli
     364    REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, t1, q1, ts1, z1
     365    REAL, DIMENSION(klon), INTENT(INOUT) :: z0m, z0h
     366    REAL, DIMENSION(klon), INTENT(IN) :: qsurf
     367    REAL, DIMENSION(klon), INTENT(IN) :: psol, pat1
     368
     369    REAL, DIMENSION(klon), INTENT(OUT) :: t_2m, q_2m, ustar
     370    REAL, DIMENSION(klon), INTENT(OUT) :: u_10m, t_10m, q_10m
     371    INTEGER, DIMENSION(klon, 6), INTENT(OUT) :: n2mout
     372
     373    REAL, DIMENSION(klon) :: u_2m
     374    REAL, DIMENSION(klon) :: cdrm2m, cdrh2m, ri2m
     375    REAL, DIMENSION(klon) :: cdram, cdrah, zri1
     376    REAL, DIMENSION(klon) :: cdmn1, cdhn1, fm1, fh1
     377    REAL, DIMENSION(klon) :: cdmn2m, cdhn2m, fm2m, fh2m
     378    REAL, DIMENSION(klon) :: ri2m_new
     379    REAL, DIMENSION(klon) :: s_pblh
     380    REAL, DIMENSION(klon) :: prain
     381    REAL, DIMENSION(klon) :: tsol
     382    !-------------------------------------------------------------------------
     383    include "YOMCST.h"
     384
     385    ! Quelques constantes et options:
     386
     387    ! RKAR : constante de von Karman
     388    REAL, PARAMETER :: RKAR = 0.40
     389    ! niter : nombre iterations calcul "corrector"
     390    !     INTEGER, parameter :: niter=6, ncon=niter-1
     391    !IM 071020     INTEGER, parameter :: niter=2, ncon=niter-1
     392    INTEGER, parameter :: niter = 2, ncon = niter
     393    !     INTEGER, parameter :: niter=6, ncon=niter
     394
     395    ! Variables locales
     396    INTEGER :: i, n
     397    REAL :: zref
     398    REAL, DIMENSION(klon) :: speed
     399    ! tpot : temperature potentielle
     400    REAL, DIMENSION(klon) :: tpot
     401    REAL, DIMENSION(klon) :: cdran
     402    ! ri1 : nb. de Richardson entre la surface --> la 1ere couche
     403    REAL, DIMENSION(klon) :: ri1
     404    DOUBLE PRECISION, parameter :: eps = 1.0D-20
     405    REAL, DIMENSION(klon) :: delu, delte, delq
     406    REAL, DIMENSION(klon) :: delh, delm
     407    REAL, DIMENSION(klon) :: delh_new, delm_new
     408    REAL, DIMENSION(klon) :: u_zref, te_zref, q_zref
     409    REAL, DIMENSION(klon) :: u_zref_pnew, te_zref_pnew, q_zref_pnew
     410    REAL, DIMENSION(klon) :: temp, pref
     411    REAL, DIMENSION(klon) :: temp_new, pref_new
     412    LOGICAL :: okri
     413    REAL, DIMENSION(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
     414    REAL, DIMENSION(klon) :: u_zref_p_new, te_zref_p_new, temp_p_new, q_zref_p_new
     415    !convergence
     416    REAL, DIMENSION(klon) :: te_zref_con, q_zref_con
     417    REAL, DIMENSION(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
     418    REAL, DIMENSION(klon) :: ok_pred, ok_corr
     419
     420    REAL, DIMENSION(klon) :: cdrm10m, cdrh10m, ri10m
     421    REAL, DIMENSION(klon) :: cdmn10m, cdhn10m, fm10m, fh10m
     422    REAL, DIMENSION(klon) :: cdn2m, cdn1, zri_zero
     423    REAL :: CEPDUE, zdu2
     424    INTEGER :: nzref, nz1
     425    LOGICAL, DIMENSION(klon) :: ok_t2m_toosmall, ok_t2m_toobig
     426    LOGICAL, DIMENSION(klon) :: ok_q2m_toosmall, ok_q2m_toobig
     427    LOGICAL, DIMENSION(klon) :: ok_u2m_toobig
     428    LOGICAL, DIMENSION(klon) :: ok_t10m_toosmall, ok_t10m_toobig
     429    LOGICAL, DIMENSION(klon) :: ok_q10m_toosmall, ok_q10m_toobig
     430    LOGICAL, DIMENSION(klon) :: ok_u10m_toobig
     431    INTEGER, DIMENSION(klon, 6) :: n10mout
     432
     433    !-------------------------------------------------------------------------
     434    CEPDUE = 0.1
     435
     436    ! n2mout : compteur des pas de temps ou t2m,q2m ou u2m sont en dehors des intervalles
     437    !          [tsurf, temp], [qsurf, q1] ou [0, speed]
     438    ! n10mout : compteur des pas de temps ou t10m,q10m ou u10m sont en dehors des intervalles
     439    !          [tsurf, temp], [qsurf, q1] ou [0, speed]
     440
     441    n2mout(:, :) = 0
     442    n10mout(:, :) = 0
     443
     444    DO i = 1, knon
     445      speed(i) = MAX(SQRT(u1(i)**2 + v1(i)**2), CEPDUE)
     446      ri1(i) = 0.0
     447    ENDDO
     448
     449    okri = .FALSE.
     450    CALL cdrag(knon, nsrf, &
     451            speed, t1, q1, z1, &
     452            psol, s_pblh, ts1, qsurf, z0m, z0h, &
     453            zri_zero, 0, &
     454            cdram, cdrah, zri1, pref, prain, tsol, pat1)
     455
     456    DO i = 1, knon
     457      ri1(i) = zri1(i)
     458      tpot(i) = t1(i) * (psol(i) / pat1(i))**RKAPPA
     459      zdu2 = MAX(CEPDUE * CEPDUE, speed(i)**2)
     460      ustar(i) = sqrt(cdram(i) * zdu2)
     461
     462    ENDDO
     463
     464    !----------First aproximation of variables at zref --------------------------
     465    zref = 2.0
     466
     467    ! calcul first-guess en utilisant dans les calculs à 2m
     468    ! le Richardson de la premiere couche atmospherique
     469
     470    CALL screencn(klon, knon, nsrf, zxli, &
     471            speed, tpot, q1, zref, &
     472            ts1, qsurf, z0m, z0h, psol, &
     473            cdram, cdrah, okri, &
     474            ri1, 1, &
     475            pref_new, delm_new, delh_new, ri2m, &
     476            s_pblh, prain, tsol, pat1)
     477
     478    DO i = 1, knon
     479      u_zref(i) = delm_new(i) * speed(i)
     480      u_zref_p(i) = u_zref(i)
     481      q_zref(i) = delh_new(i) * max(q1(i), 0.0) + &
     482              max(qsurf(i), 0.0) * (1 - delh_new(i))
     483      q_zref_p(i) = q_zref(i)
     484      te_zref(i) = delh_new(i) * tpot(i) + ts1(i) * (1 - delh_new(i))
     485      te_zref_p(i) = te_zref(i)
     486
     487      ! return to normal temperature
     488      temp(i) = te_zref(i) * (psol(i) / pref_new(i))**(-RKAPPA)
     489      temp_p(i) = temp(i)
     490
     491      ! compteurs ici
     492
     493      ok_t2m_toosmall(i) = te_zref(i)<tpot(i).AND. &
     494              te_zref(i)<ts1(i)
     495      ok_t2m_toobig(i) = te_zref(i)>tpot(i).AND. &
     496              te_zref(i)>ts1(i)
     497      ok_q2m_toosmall(i) = q_zref(i)<q1(i).AND. &
     498              q_zref(i)<qsurf(i)
     499      ok_q2m_toobig(i) = q_zref(i)>q1(i).AND. &
     500              q_zref(i)>qsurf(i)
     501      ok_u2m_toobig(i) = u_zref(i)>speed(i)
     502
     503      IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i)) THEN
     504        n2mout(i, 1) = n2mout(i, 1) + 1
     505      ENDIF
     506      IF(ok_q2m_toosmall(i).OR.ok_q2m_toobig(i)) THEN
     507        n2mout(i, 3) = n2mout(i, 3) + 1
     508      ENDIF
     509      IF(ok_u2m_toobig(i)) THEN
     510        n2mout(i, 5) = n2mout(i, 5) + 1
     511      ENDIF
     512
     513      IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i).OR. &
     514              ok_q2m_toosmall(i).OR.ok_q2m_toobig(i).OR. &
     515              ok_u2m_toobig(i)) THEN
     516        delm_new(i) = min(max(delm_new(i), 0.), 1.)
     517        delh_new(i) = min(max(delh_new(i), 0.), 1.)
     518        u_zref(i) = delm_new(i) * speed(i)
    275519        u_zref_p(i) = u_zref(i)
     520        q_zref(i) = delh_new(i) * max(q1(i), 0.0) + &
     521                max(qsurf(i), 0.0) * (1 - delh_new(i))
     522        q_zref_p(i) = q_zref(i)
     523        te_zref(i) = delh_new(i) * tpot(i) + ts1(i) * (1 - delh_new(i))
     524        te_zref_p(i) = te_zref(i)
     525
     526        ! return to normal temperature
     527        temp(i) = te_zref(i) * (psol(i) / pref_new(i))**(-RKAPPA)
     528        temp_p(i) = temp(i)
     529      ENDIF
     530
     531    ENDDO
     532
     533    ! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995
     534
     535    DO n = 1, niter
     536
     537      okri = .TRUE.
     538      CALL screencn(klon, knon, nsrf, zxli, &
     539              u_zref, temp, q_zref, zref, &
     540              ts1, qsurf, z0m, z0h, psol, &
     541              cdram, cdrah, okri, &
     542              ri1, 0, &
     543              pref, delm, delh, ri2m, &
     544              s_pblh, prain, tsol, pat1)
     545
     546      DO i = 1, knon
     547        u_zref(i) = delm(i) * speed(i)
     548        q_zref(i) = delh(i) * max(q1(i), 0.0) + &
     549                max(qsurf(i), 0.0) * (1 - delh(i))
     550        te_zref(i) = delh(i) * tpot(i) + ts1(i) * (1 - delh(i))
     551
     552        ! return to normal temperature
     553        temp(i) = te_zref(i) * (psol(i) / pref(i))**(-RKAPPA)
     554
     555        ! compteurs ici
     556
     557        ok_t2m_toosmall(i) = te_zref(i)<tpot(i).AND. &
     558                te_zref(i)<ts1(i)
     559        ok_t2m_toobig(i) = te_zref(i)>tpot(i).AND. &
     560                te_zref(i)>ts1(i)
     561        ok_q2m_toosmall(i) = q_zref(i)<q1(i).AND. &
     562                q_zref(i)<qsurf(i)
     563        ok_q2m_toobig(i) = q_zref(i)>q1(i).AND. &
     564                q_zref(i)>qsurf(i)
     565        ok_u2m_toobig(i) = u_zref(i)>speed(i)
     566
     567        IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i)) THEN
     568          n2mout(i, 2) = n2mout(i, 2) + 1
     569        ENDIF
     570        IF(ok_q2m_toosmall(i).OR.ok_q2m_toobig(i)) THEN
     571          n2mout(i, 4) = n2mout(i, 4) + 1
     572        ENDIF
     573        IF(ok_u2m_toobig(i)) THEN
     574          n2mout(i, 6) = n2mout(i, 6) + 1
     575        ENDIF
     576
     577        IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i).OR. &
     578                ok_q2m_toosmall(i).OR.ok_q2m_toobig(i).OR. &
     579                ok_u2m_toobig(i)) THEN
     580          delm(i) = min(max(delm(i), 0.), 1.)
     581          delh(i) = min(max(delh(i), 0.), 1.)
     582          u_zref(i) = delm(i) * speed(i)
     583          q_zref(i) = delh(i) * max(q1(i), 0.0) + &
     584                  max(qsurf(i), 0.0) * (1 - delh(i))
     585          te_zref(i) = delh(i) * tpot(i) + ts1(i) * (1 - delh(i))
     586          temp(i) = te_zref(i) * (psol(i) / pref(i))**(-RKAPPA)
     587        ENDIF
     588
     589        IF(n==ncon) THEN
     590          te_zref_con(i) = te_zref(i)
     591          q_zref_con(i) = q_zref(i)
     592        ENDIF
     593
    276594      ENDDO
    277595
    278 ! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995
    279 
    280       DO n = 1, niter
    281 
    282         okri=.TRUE.
    283         CALL screenc(klon, knon, nsrf, zxli, &
    284                      u_zref, temp, q_zref, zref, &
    285                      ts1, qsurf, z0m, z0h, psol, &
    286                      ustar, testar, qstar, okri, ri1, &
    287                      pref, delu, delte, delq, s_pblh ,prain, tsol, pat1)
    288 
    289         DO i = 1, knon
    290           u_zref(i) = delu(i)
    291           q_zref(i) = delq(i) + max(qsurf(i),0.0)
    292           te_zref(i) = delte(i) + ts1(i)
    293           temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
    294 !         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
    295 !                   (1 + RVTMP2 * max(q_zref(i),0.0))
    296         ENDDO
     596    ENDDO
     597
     598    DO i = 1, knon
     599      q_zref_c(i) = q_zref(i)
     600      temp_c(i) = temp(i)
     601
     602      ok_pred(i) = 0.
     603      ok_corr(i) = 1.
     604
     605      t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
     606      q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
     607
     608      u_zref_c(i) = u_zref(i)
     609      u_2m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
     610    ENDDO
     611
     612
     613    !----------First aproximation of variables at zref --------------------------
     614
     615    zref = 10.0
     616
     617    CALL screencn(klon, knon, nsrf, zxli, &
     618            speed, tpot, q1, zref, &
     619            ts1, qsurf, z0m, z0h, psol, &
     620            cdram, cdrah, okri, &
     621            ri1, 1, &
     622            pref_new, delm_new, delh_new, ri10m, &
     623            s_pblh, prain, tsol, pat1)
     624
     625    DO i = 1, knon
     626      u_zref(i) = delm_new(i) * speed(i)
     627      q_zref(i) = delh_new(i) * max(q1(i), 0.0) + &
     628              max(qsurf(i), 0.0) * (1 - delh_new(i))
     629      te_zref(i) = delh_new(i) * tpot(i) + ts1(i) * (1 - delh_new(i))
     630      temp(i) = te_zref(i) * (psol(i) / pref_new(i))**(-RKAPPA)
     631      u_zref_p(i) = u_zref(i)
     632
     633      ! compteurs ici
     634
     635      ok_t10m_toosmall(i) = te_zref(i)<tpot(i).AND. &
     636              te_zref(i)<ts1(i)
     637      ok_t10m_toobig(i) = te_zref(i)>tpot(i).AND. &
     638              te_zref(i)>ts1(i)
     639      ok_q10m_toosmall(i) = q_zref(i)<q1(i).AND. &
     640              q_zref(i)<qsurf(i)
     641      ok_q10m_toobig(i) = q_zref(i)>q1(i).AND. &
     642              q_zref(i)>qsurf(i)
     643      ok_u10m_toobig(i) = u_zref(i)>speed(i)
     644
     645      IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i)) THEN
     646        n10mout(i, 1) = n10mout(i, 1) + 1
     647      ENDIF
     648      IF(ok_q10m_toosmall(i).OR.ok_q10m_toobig(i)) THEN
     649        n10mout(i, 3) = n10mout(i, 3) + 1
     650      ENDIF
     651      IF(ok_u10m_toobig(i)) THEN
     652        n10mout(i, 5) = n10mout(i, 5) + 1
     653      ENDIF
     654
     655      IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i).OR. &
     656              ok_q10m_toosmall(i).OR.ok_q10m_toobig(i).OR. &
     657              ok_u10m_toobig(i)) THEN
     658        delm_new(i) = min(max(delm_new(i), 0.), 1.)
     659        delh_new(i) = min(max(delh_new(i), 0.), 1.)
     660        u_zref(i) = delm_new(i) * speed(i)
     661        u_zref_p(i) = u_zref(i)
     662        q_zref(i) = delh_new(i) * max(q1(i), 0.0) + &
     663                max(qsurf(i), 0.0) * (1 - delh_new(i))
     664        te_zref(i) = delh_new(i) * tpot(i) + ts1(i) * (1 - delh_new(i))
     665        temp(i) = te_zref(i) * (psol(i) / pref_new(i))**(-RKAPPA)
     666      ENDIF
     667
     668    ENDDO
     669
     670    ! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995
     671
     672    DO n = 1, niter
     673
     674      okri = .TRUE.
     675      CALL screencn(klon, knon, nsrf, zxli, &
     676              u_zref, temp, q_zref, zref, &
     677              ts1, qsurf, z0m, z0h, psol, &
     678              cdram, cdrah, okri, &
     679              ri1, 0, &
     680              pref, delm, delh, ri10m, &
     681              s_pblh, prain, tsol, pat1)
     682
     683      DO i = 1, knon
     684        u_zref(i) = delm(i) * speed(i)
     685        q_zref(i) = delh(i) * max(q1(i), 0.0) + &
     686                max(qsurf(i), 0.0) * (1 - delh(i))
     687        te_zref(i) = delh(i) * tpot(i) + ts1(i) * (1 - delh(i))
     688
     689        ! return to normal temperature
     690        temp(i) = te_zref(i) * (psol(i) / pref(i))**(-RKAPPA)
     691
     692        ! compteurs ici
     693
     694        ok_t10m_toosmall(i) = te_zref(i)<tpot(i).AND. &
     695                te_zref(i)<ts1(i)
     696        ok_t10m_toobig(i) = te_zref(i)>tpot(i).AND. &
     697                te_zref(i)>ts1(i)
     698        ok_q10m_toosmall(i) = q_zref(i)<q1(i).AND. &
     699                q_zref(i)<qsurf(i)
     700        ok_q10m_toobig(i) = q_zref(i)>q1(i).AND. &
     701                q_zref(i)>qsurf(i)
     702        ok_u10m_toobig(i) = u_zref(i)>speed(i)
     703
     704        IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i)) THEN
     705          n10mout(i, 2) = n10mout(i, 2) + 1
     706        ENDIF
     707        IF(ok_q10m_toosmall(i).OR.ok_q10m_toobig(i)) THEN
     708          n10mout(i, 4) = n10mout(i, 4) + 1
     709        ENDIF
     710        IF(ok_u10m_toobig(i)) THEN
     711          n10mout(i, 6) = n10mout(i, 6) + 1
     712        ENDIF
     713
     714        IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i).OR. &
     715                ok_q10m_toosmall(i).OR.ok_q10m_toobig(i).OR. &
     716                ok_u10m_toobig(i)) THEN
     717          delm(i) = min(max(delm(i), 0.), 1.)
     718          delh(i) = min(max(delh(i), 0.), 1.)
     719          u_zref(i) = delm(i) * speed(i)
     720          q_zref(i) = delh(i) * max(q1(i), 0.0) + &
     721                  max(qsurf(i), 0.0) * (1 - delh(i))
     722          te_zref(i) = delh(i) * tpot(i) + ts1(i) * (1 - delh(i))
     723          temp(i) = te_zref(i) * (psol(i) / pref(i))**(-RKAPPA)
     724        ENDIF
     725
     726        IF(n==ncon) THEN
     727          te_zref_con(i) = te_zref(i)
     728          q_zref_con(i) = q_zref(i)
     729        ENDIF
    297730
    298731      ENDDO
    299732
    300       DO i = 1, knon
    301         u_zref_c(i) = u_zref(i)
    302 
    303         u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
    304 
    305 !AM
    306         q_zref_c(i) = q_zref(i)
    307         temp_c(i) = temp(i)
    308         t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
    309         q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
    310 !MA
    311       ENDDO
    312 
    313 
    314       END SUBROUTINE stdlevvar
    315 
    316       SUBROUTINE stdlevvarn(klon, knon, nsrf, zxli, &
    317                            u1, v1, t1, q1, z1, &
    318                            ts1, qsurf, z0m, z0h, psol, pat1, &
    319                            t_2m, q_2m, t_10m, q_10m, u_10m, ustar, &
    320                            n2mout)
    321 
    322       USE lmdz_ioipsl_getin_p, ONLY: getin_p
    323       USE lmdz_flux_arp, ONLY: fsens, flat, betaevap, ust, tg, ok_flux_surf, ok_prescr_ust, ok_prescr_beta, ok_forc_tsurf
    324 
    325       IMPLICIT NONE
    326 !-------------------------------------------------------------------------
    327 
    328 ! Objet : calcul de la temperature et l'humidite relative a 2m et du
    329 !         module du vent a 10m a partir des relations de Dyer-Businger et
    330 !         des equations de Louis.
    331 
    332 ! Reference : Hess, Colman et McAvaney (1995)       
    333 
    334 ! I. Musat, 01.07.2002
    335 
    336 !AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
    337 
    338 !-------------------------------------------------------------------------
    339 
    340 ! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
    341 ! knon----input-I- nombre de points pour un type de surface
    342 ! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
    343 ! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
    344 ! u1------input-R- vent zonal au 1er niveau du modele
    345 ! v1------input-R- vent meridien au 1er niveau du modele
    346 ! t1------input-R- temperature de l'air au 1er niveau du modele
    347 ! q1------input-R- humidite relative au 1er niveau du modele
    348 ! z1------input-R- geopotentiel au 1er niveau du modele
    349 ! ts1-----input-R- temperature de l'air a la surface
    350 ! qsurf---input-R- humidite relative a la surface
    351 ! z0m, z0h---input-R- rugosite
    352 ! psol----input-R- pression au sol
    353 ! pat1----input-R- pression au 1er niveau du modele
    354 
    355 ! t_2m---output-R- temperature de l'air a 2m
    356 ! q_2m---output-R- humidite relative a 2m
    357 ! u_2m--output-R- vitesse du vent a 2m
    358 ! u_10m--output-R- vitesse du vent a 10m
    359 ! ustar--output-R- u*
    360 !AM
    361 ! t_10m--output-R- temperature de l'air a 10m
    362 ! q_10m--output-R- humidite specifique a 10m
    363 
    364       INTEGER, INTENT(IN) :: klon, knon, nsrf
    365       LOGICAL, INTENT(IN) :: zxli
    366       REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, t1, q1, ts1, z1
    367       REAL, DIMENSION(klon), INTENT(INOUT) :: z0m, z0h
    368       REAL, DIMENSION(klon), INTENT(IN) :: qsurf
    369       REAL, DIMENSION(klon), INTENT(IN) :: psol, pat1
    370 
    371       REAL, DIMENSION(klon), INTENT(OUT) :: t_2m, q_2m, ustar
    372       REAL, DIMENSION(klon), INTENT(OUT) :: u_10m, t_10m, q_10m
    373       INTEGER, DIMENSION(klon, 6), INTENT(OUT) :: n2mout
    374 
    375       REAL, DIMENSION(klon) :: u_2m
    376       REAL, DIMENSION(klon) :: cdrm2m, cdrh2m, ri2m
    377       REAL, DIMENSION(klon) :: cdram, cdrah, zri1
    378       REAL, DIMENSION(klon) :: cdmn1, cdhn1, fm1, fh1
    379       REAL, DIMENSION(klon) :: cdmn2m, cdhn2m, fm2m, fh2m
    380       REAL, DIMENSION(klon) :: ri2m_new
    381       REAL, DIMENSION(klon) :: s_pblh
    382       REAL, DIMENSION(klon) :: prain
    383       REAL, DIMENSION(klon) :: tsol
    384 !-------------------------------------------------------------------------
    385       include "YOMCST.h"
    386 !IM PLUS
    387       include "YOETHF.h"
    388 
    389 ! Quelques constantes et options:
    390 
    391 ! RKAR : constante de von Karman
    392       REAL, PARAMETER :: RKAR=0.40
    393 ! niter : nombre iterations calcul "corrector"
    394 !     INTEGER, parameter :: niter=6, ncon=niter-1
    395 !IM 071020     INTEGER, parameter :: niter=2, ncon=niter-1
    396       INTEGER, parameter :: niter=2, ncon=niter
    397 !     INTEGER, parameter :: niter=6, ncon=niter
    398 
    399 ! Variables locales
    400       INTEGER :: i, n
    401       REAL :: zref
    402       REAL, DIMENSION(klon) :: speed
    403 ! tpot : temperature potentielle
    404       REAL, DIMENSION(klon) :: tpot
    405       REAL, DIMENSION(klon) :: cdran
    406 ! ri1 : nb. de Richardson entre la surface --> la 1ere couche
    407       REAL, DIMENSION(klon) :: ri1
    408       DOUBLE PRECISION, parameter :: eps=1.0D-20
    409       REAL, DIMENSION(klon) :: delu, delte, delq
    410       REAL, DIMENSION(klon) :: delh, delm
    411       REAL, DIMENSION(klon) :: delh_new, delm_new
    412       REAL, DIMENSION(klon) :: u_zref, te_zref, q_zref
    413       REAL, DIMENSION(klon) :: u_zref_pnew, te_zref_pnew, q_zref_pnew
    414       REAL, DIMENSION(klon) :: temp, pref
    415       REAL, DIMENSION(klon) :: temp_new, pref_new
    416       LOGICAL :: okri
    417       REAL, DIMENSION(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
    418       REAL, DIMENSION(klon) :: u_zref_p_new, te_zref_p_new, temp_p_new, q_zref_p_new
    419 !convergence
    420       REAL, DIMENSION(klon) :: te_zref_con, q_zref_con
    421       REAL, DIMENSION(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
    422       REAL, DIMENSION(klon) :: ok_pred, ok_corr
    423 
    424       REAL, DIMENSION(klon) :: cdrm10m, cdrh10m, ri10m
    425       REAL, DIMENSION(klon) :: cdmn10m, cdhn10m, fm10m, fh10m
    426       REAL, DIMENSION(klon) :: cdn2m, cdn1, zri_zero
    427       REAL :: CEPDUE,zdu2
    428       INTEGER :: nzref, nz1
    429       LOGICAL, DIMENSION(klon) :: ok_t2m_toosmall, ok_t2m_toobig
    430       LOGICAL, DIMENSION(klon) :: ok_q2m_toosmall, ok_q2m_toobig
    431       LOGICAL, DIMENSION(klon) :: ok_u2m_toobig
    432       LOGICAL, DIMENSION(klon) :: ok_t10m_toosmall, ok_t10m_toobig
    433       LOGICAL, DIMENSION(klon) :: ok_q10m_toosmall, ok_q10m_toobig
    434       LOGICAL, DIMENSION(klon) :: ok_u10m_toobig
    435       INTEGER, DIMENSION(klon, 6) :: n10mout
    436 
    437 !-------------------------------------------------------------------------
    438       CEPDUE=0.1
    439 
    440 ! n2mout : compteur des pas de temps ou t2m,q2m ou u2m sont en dehors des intervalles
    441 !          [tsurf, temp], [qsurf, q1] ou [0, speed]
    442 ! n10mout : compteur des pas de temps ou t10m,q10m ou u10m sont en dehors des intervalles
    443 !          [tsurf, temp], [qsurf, q1] ou [0, speed]
    444 
    445       n2mout(:,:)=0
    446       n10mout(:,:)=0
    447      
    448       DO i=1, knon
    449        speed(i)=MAX(SQRT(u1(i)**2+v1(i)**2),CEPDUE)
    450        ri1(i) = 0.0
    451       ENDDO
    452 
    453       okri=.FALSE.
    454       CALL cdrag(knon, nsrf, &
    455                      speed, t1, q1, z1, &
    456                      psol, s_pblh, ts1, qsurf, z0m, z0h, &
    457                      zri_zero, 0, &
    458                      cdram, cdrah, zri1, pref, prain, tsol, pat1)
    459 
    460       DO i = 1, knon
    461         ri1(i) = zri1(i)
    462         tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA
    463         zdu2 = MAX(CEPDUE*CEPDUE, speed(i)**2)
    464         ustar(i) = sqrt(cdram(i) * zdu2)
    465 
    466       ENDDO
    467 
    468 !----------First aproximation of variables at zref --------------------------
    469       zref = 2.0
    470 
    471 ! calcul first-guess en utilisant dans les calculs à 2m
    472 ! le Richardson de la premiere couche atmospherique
    473 
    474        CALL screencn(klon, knon, nsrf, zxli, &
    475                      speed, tpot, q1, zref, &
    476                      ts1, qsurf, z0m, z0h, psol, &
    477                      cdram, cdrah,  okri, &
    478                      ri1, 1, &
    479                      pref_new, delm_new, delh_new, ri2m, &
    480                      s_pblh, prain, tsol, pat1      )
    481 
    482        DO i = 1, knon
    483          u_zref(i) = delm_new(i)*speed(i)
    484          u_zref_p(i) = u_zref(i)
    485          q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
    486              max(qsurf(i),0.0)*(1-delh_new(i))
    487          q_zref_p(i) = q_zref(i)
    488          te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
    489          te_zref_p(i) = te_zref(i)
    490 
    491 ! return to normal temperature
    492          temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
    493          temp_p(i) = temp(i)
    494 
    495 ! compteurs ici
    496 
    497          ok_t2m_toosmall(i)=te_zref(i)<tpot(i).AND. &
    498    te_zref(i)<ts1(i)
    499          ok_t2m_toobig(i)=te_zref(i)>tpot(i).AND. &
    500    te_zref(i)>ts1(i)
    501          ok_q2m_toosmall(i)=q_zref(i)<q1(i).AND. &
    502    q_zref(i)<qsurf(i)
    503          ok_q2m_toobig(i)=q_zref(i)>q1(i).AND. &
    504    q_zref(i)>qsurf(i)
    505          ok_u2m_toobig(i)=u_zref(i)>speed(i)
    506 
    507          IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i)) THEN
    508              n2mout(i,1)=n2mout(i,1)+1
    509          ENDIF
    510          IF(ok_q2m_toosmall(i).OR.ok_q2m_toobig(i)) THEN
    511              n2mout(i,3)=n2mout(i,3)+1
    512          ENDIF
    513          IF(ok_u2m_toobig(i)) THEN
    514              n2mout(i,5)=n2mout(i,5)+1
    515          ENDIF
    516 
    517          IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i).OR. &
    518    ok_q2m_toosmall(i).OR.ok_q2m_toobig(i).OR. &
    519    ok_u2m_toobig(i)) THEN
    520              delm_new(i)=min(max(delm_new(i),0.),1.)
    521              delh_new(i)=min(max(delh_new(i),0.),1.)
    522              u_zref(i) = delm_new(i)*speed(i)
    523              u_zref_p(i) = u_zref(i)
    524              q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
    525                  max(qsurf(i),0.0)*(1-delh_new(i))
    526              q_zref_p(i) = q_zref(i)
    527              te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
    528              te_zref_p(i) = te_zref(i)
    529 
    530 ! return to normal temperature
    531              temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
    532              temp_p(i) = temp(i)
    533          ENDIF
    534 
    535        ENDDO
    536 
    537 ! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995
    538 
    539       DO n = 1, niter
    540 
    541         okri=.TRUE.
    542         CALL screencn(klon, knon, nsrf, zxli, &
    543                      u_zref, temp, q_zref, zref, &
    544                      ts1, qsurf, z0m, z0h, psol, &
    545                      cdram, cdrah,  okri, &
    546                      ri1, 0, &
    547                      pref, delm, delh, ri2m, &
    548                      s_pblh, prain, tsol, pat1      )
    549 
    550         DO i = 1, knon
    551           u_zref(i) = delm(i)*speed(i)
    552           q_zref(i) = delh(i)*max(q1(i),0.0) + &
    553              max(qsurf(i),0.0)*(1-delh(i))
    554           te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
    555 
    556 ! return to normal temperature
    557           temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
    558 
    559 ! compteurs ici
    560 
    561           ok_t2m_toosmall(i)=te_zref(i)<tpot(i).AND. &
    562    te_zref(i)<ts1(i)
    563           ok_t2m_toobig(i)=te_zref(i)>tpot(i).AND. &
    564    te_zref(i)>ts1(i)
    565           ok_q2m_toosmall(i)=q_zref(i)<q1(i).AND. &
    566    q_zref(i)<qsurf(i)
    567           ok_q2m_toobig(i)=q_zref(i)>q1(i).AND. &
    568    q_zref(i)>qsurf(i)
    569           ok_u2m_toobig(i)=u_zref(i)>speed(i)
    570 
    571           IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i)) THEN
    572               n2mout(i,2)=n2mout(i,2)+1
    573           ENDIF
    574           IF(ok_q2m_toosmall(i).OR.ok_q2m_toobig(i)) THEN
    575               n2mout(i,4)=n2mout(i,4)+1
    576           ENDIF
    577           IF(ok_u2m_toobig(i)) THEN
    578               n2mout(i,6)=n2mout(i,6)+1
    579           ENDIF
    580 
    581           IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i).OR. &
    582    ok_q2m_toosmall(i).OR.ok_q2m_toobig(i).OR. &
    583    ok_u2m_toobig(i)) THEN
    584               delm(i)=min(max(delm(i),0.),1.)
    585               delh(i)=min(max(delh(i),0.),1.)
    586               u_zref(i) = delm(i)*speed(i)
    587               q_zref(i) = delh(i)*max(q1(i),0.0) + &
    588              max(qsurf(i),0.0)*(1-delh(i))
    589               te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
    590               temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
    591           ENDIF
    592 
    593 
    594           IF(n==ncon) THEN
    595             te_zref_con(i) = te_zref(i)
    596             q_zref_con(i) = q_zref(i)
    597           ENDIF
    598 
    599         ENDDO
    600 
    601       ENDDO
    602 
    603       DO i = 1, knon
    604         q_zref_c(i) = q_zref(i)
    605         temp_c(i) = temp(i)
    606 
    607         ok_pred(i)=0.
    608         ok_corr(i)=1.
    609 
    610         t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
    611         q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
    612 
    613         u_zref_c(i) = u_zref(i)
    614         u_2m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
    615       ENDDO
    616 
    617 
    618 !----------First aproximation of variables at zref --------------------------
    619 
    620       zref = 10.0
    621 
    622        CALL screencn(klon, knon, nsrf, zxli, &
    623                      speed, tpot, q1, zref, &
    624                      ts1, qsurf, z0m, z0h, psol, &
    625                      cdram, cdrah,  okri, &
    626                      ri1, 1, &
    627                      pref_new, delm_new, delh_new, ri10m, &
    628                      s_pblh, prain, tsol, pat1      )
    629 
    630        DO i = 1, knon
    631          u_zref(i) = delm_new(i)*speed(i)
    632          q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
    633              max(qsurf(i),0.0)*(1-delh_new(i))
    634          te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
    635          temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
    636          u_zref_p(i) = u_zref(i)
    637 
    638 ! compteurs ici
    639 
    640          ok_t10m_toosmall(i)=te_zref(i)<tpot(i).AND. &
    641    te_zref(i)<ts1(i)
    642          ok_t10m_toobig(i)=te_zref(i)>tpot(i).AND. &
    643    te_zref(i)>ts1(i)
    644          ok_q10m_toosmall(i)=q_zref(i)<q1(i).AND. &
    645    q_zref(i)<qsurf(i)
    646          ok_q10m_toobig(i)=q_zref(i)>q1(i).AND. &
    647    q_zref(i)>qsurf(i)
    648          ok_u10m_toobig(i)=u_zref(i)>speed(i)
    649 
    650          IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i)) THEN
    651              n10mout(i,1)=n10mout(i,1)+1
    652          ENDIF
    653          IF(ok_q10m_toosmall(i).OR.ok_q10m_toobig(i)) THEN
    654              n10mout(i,3)=n10mout(i,3)+1
    655          ENDIF
    656          IF(ok_u10m_toobig(i)) THEN
    657              n10mout(i,5)=n10mout(i,5)+1
    658          ENDIF
    659 
    660          IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i).OR. &
    661    ok_q10m_toosmall(i).OR.ok_q10m_toobig(i).OR. &
    662    ok_u10m_toobig(i)) THEN
    663              delm_new(i)=min(max(delm_new(i),0.),1.)
    664              delh_new(i)=min(max(delh_new(i),0.),1.)
    665              u_zref(i) = delm_new(i)*speed(i)
    666              u_zref_p(i) = u_zref(i)
    667              q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
    668                  max(qsurf(i),0.0)*(1-delh_new(i))
    669              te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
    670              temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
    671          ENDIF
    672 
    673        ENDDO
    674 
    675 ! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995
    676 
    677       DO n = 1, niter
    678 
    679         okri=.TRUE.
    680         CALL screencn(klon, knon, nsrf, zxli, &
    681                      u_zref, temp, q_zref, zref, &
    682                      ts1, qsurf, z0m, z0h, psol, &
    683                      cdram, cdrah,  okri, &
    684                      ri1, 0, &
    685                      pref, delm, delh, ri10m, &
    686                      s_pblh, prain, tsol, pat1      )
    687 
    688         DO i = 1, knon
    689           u_zref(i) = delm(i)*speed(i)
    690           q_zref(i) = delh(i)*max(q1(i),0.0) + &
    691              max(qsurf(i),0.0)*(1-delh(i))
    692           te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
    693 
    694 ! return to normal temperature
    695           temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
    696 
    697 ! compteurs ici
    698 
    699           ok_t10m_toosmall(i)=te_zref(i)<tpot(i).AND. &
    700    te_zref(i)<ts1(i)
    701           ok_t10m_toobig(i)=te_zref(i)>tpot(i).AND. &
    702    te_zref(i)>ts1(i)
    703           ok_q10m_toosmall(i)=q_zref(i)<q1(i).AND. &
    704    q_zref(i)<qsurf(i)
    705           ok_q10m_toobig(i)=q_zref(i)>q1(i).AND. &
    706    q_zref(i)>qsurf(i)
    707           ok_u10m_toobig(i)=u_zref(i)>speed(i)
    708 
    709           IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i)) THEN
    710               n10mout(i,2)=n10mout(i,2)+1
    711           ENDIF
    712           IF(ok_q10m_toosmall(i).OR.ok_q10m_toobig(i)) THEN
    713               n10mout(i,4)=n10mout(i,4)+1
    714           ENDIF
    715           IF(ok_u10m_toobig(i)) THEN
    716               n10mout(i,6)=n10mout(i,6)+1
    717           ENDIF
    718 
    719           IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i).OR. &
    720    ok_q10m_toosmall(i).OR.ok_q10m_toobig(i).OR. &
    721    ok_u10m_toobig(i)) THEN
    722               delm(i)=min(max(delm(i),0.),1.)
    723               delh(i)=min(max(delh(i),0.),1.)
    724               u_zref(i) = delm(i)*speed(i)
    725               q_zref(i) = delh(i)*max(q1(i),0.0) + &
    726              max(qsurf(i),0.0)*(1-delh(i))
    727               te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
    728               temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
    729           ENDIF
    730 
    731 
    732           IF(n==ncon) THEN
    733             te_zref_con(i) = te_zref(i)
    734             q_zref_con(i) = q_zref(i)
    735           ENDIF
    736 
    737         ENDDO
    738 
    739       ENDDO
    740 
    741       DO i = 1, knon
    742         q_zref_c(i) = q_zref(i)
    743         temp_c(i) = temp(i)
    744 
    745         ok_pred(i)=0.
    746         ok_corr(i)=1.
    747 
    748         t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
    749         q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
    750 
    751         u_zref_c(i) = u_zref(i)
    752         u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
    753       ENDDO
    754 
    755 
    756       END SUBROUTINE stdlevvarn
     733    ENDDO
     734
     735    DO i = 1, knon
     736      q_zref_c(i) = q_zref(i)
     737      temp_c(i) = temp(i)
     738
     739      ok_pred(i) = 0.
     740      ok_corr(i) = 1.
     741
     742      t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
     743      q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
     744
     745      u_zref_c(i) = u_zref(i)
     746      u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
     747    ENDDO
     748
     749  END SUBROUTINE stdlevvarn
    757750
    758751END MODULE stdlevvar_mod

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

    r5116 r5143  
    33
    44SUBROUTINE suphel
     5  USE lmdz_YOETHF
    56
    67  IMPLICIT NONE
    78
    89  include "YOMCST.h"
    9   include "YOETHF.h"
    1010  ! IM cf. JLD
    1111  LOGICAL firstcall

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

    r5137 r5143  
    3535    USE indice_sol_mod, ONLY: is_oce
    3636    USE lmdz_clesphys
     37    USE lmdz_YOETHF
     38    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    3739
    3840    INCLUDE "YOMCST.h"
    39     INCLUDE "FCTTRE.h"
    40     INCLUDE "YOETHF.h"
    4141
    4242    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
    … …  
    169169
    170170    USE lmdz_print_control, ONLY: prt_level,lunout
     171    USE lmdz_YOETHF
     172    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    171173
    172174    INCLUDE "YOMCST.h"
    173     INCLUDE "FCTTRE.h"
    174     INCLUDE "YOETHF.h"
    175175
    176176    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
    … …  
    721721
    722722    USE lmdz_print_control, ONLY: prt_level,lunout
     723    USE lmdz_YOETHF
     724    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    723725
    724726    INCLUDE "YOMCST.h"
    725     INCLUDE "FCTTRE.h"
    726     INCLUDE "YOETHF.h"
    727727
    728728    INTEGER,                      INTENT(IN)        :: knon         ! number of grid cells
    … …  
    964964
    965965    USE lmdz_print_control, ONLY: prt_level,lunout
     966    USE lmdz_YOETHF
     967    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    966968
    967969    INCLUDE "YOMCST.h"
    968     INCLUDE "FCTTRE.h"
    969     INCLUDE "YOETHF.h"
    970970
    971971    INTEGER,                      INTENT(IN)        :: knon         ! number of grid cells

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

    r5137 r5143  
    318318    USE indice_sol_mod, ONLY: is_oce
    319319    USE lmdz_clesphys
     320    USE lmdz_YOETHF
     321    USE lmdz_fcttre, ONLY: foeew, foede, qsats, qsatl, dqsats, dqsatl, thermcep
    320322
    321323    INCLUDE "YOMCST.h"
    322     INCLUDE "FCTTRE.h"
    323     INCLUDE "YOETHF.h"
    324324
    325325    INTEGER, INTENT(IN) :: knon    ! number of grid cells
Note: See TracChangeset for help on using the changeset viewer.