Changeset 5119


Ignore:
Timestamp:
Jul 24, 2024, 6:46:45 PM (12 months ago)
Author:
abarral
Message:

enforce PRIVATE by default in several modules, expose PUBLIC as needed
move eigen.f90 to obsolete/
(lint) aslong the way

Location:
LMDZ6/branches/Amaury_dev/libf
Files:
113 edited
1 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/advtrac.f90

    r5118 r5119  
    1717  USE lmdz_libmath, ONLY: minmax
    1818  USE lmdz_iniprint, ONLY: lunout, prt_level
     19  USE lmdz_ssum_scopy, ONLY: scopy
    1920
    2021  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/caladvtrac.F90

    r5117 r5119  
    1111  USE comconst_mod, ONLY: dtvr
    1212  USE lmdz_filtreg, ONLY: filtreg
     13  USE lmdz_ssum_scopy, ONLY: scopy
    1314
    1415  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/fluxstokenc.F90

    r5118 r5119  
    77  USE IOIPSL
    88  USE lmdz_iniprint, ONLY: lunout, prt_level
     9  USE lmdz_ssum_scopy, ONLY: scopy
    910  !
    1011  ! Auteur :  F. Hourdin

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/groupe.F90

    r5117 r5119  
    44
    55  USE comconst_mod, ONLY: ngroup
     6  USE lmdz_ssum_scopy, ONLY: scopy
    67
    78  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/integrd.F90

    r5118 r5119  
    1212  USE temps_mod, ONLY: dt
    1313  USE lmdz_iniprint, ONLY: lunout, prt_level
     14  USE lmdz_ssum_scopy, ONLY: scopy
    1415
    1516  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/leapfrog.F90

    r5118 r5119  
    2727  USE lmdz_description, ONLY: descript
    2828  USE lmdz_iniprint, ONLY: lunout, prt_level
     29  USE lmdz_ssum_scopy, ONLY: scopy
    2930
    3031  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/vlsplt.F90

    r5118 r5119  
    33!
    44
    5 SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt,iq)
    6   USE infotrac, ONLY: nqtot,tracers
     5SUBROUTINE vlsplt(q, pente_max, masse, w, pbaru, pbarv, pdt, iq)
     6  USE infotrac, ONLY: nqtot, tracers
     7  USE lmdz_ssum_scopy, ONLY: scopy
    78  !
    89  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    2728  !   Arguments:
    2829  !   ----------
    29   REAL :: masse(ip1jmp1,llm),pente_max
    30   REAL :: pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
    31   REAL :: q(ip1jmp1,llm,nqtot)
    32   REAL :: w(ip1jmp1,llm),pdt
     30  REAL :: masse(ip1jmp1, llm), pente_max
     31  REAL :: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
     32  REAL :: q(ip1jmp1, llm, nqtot)
     33  REAL :: w(ip1jmp1, llm), pdt
    3334  INTEGER :: iq ! CRisi
    3435  !
    … …  
    3637  !   ---------
    3738  !
    38   INTEGER :: ij,l
    39   !
    40   REAL :: zm(ip1jmp1,llm,nqtot)
    41   REAL :: mu(ip1jmp1,llm)
    42   REAL :: mv(ip1jm,llm)
    43   REAL :: mw(ip1jmp1,llm+1)
    44   REAL :: zq(ip1jmp1,llm,nqtot)
     39  INTEGER :: ij, l
     40  !
     41  REAL :: zm(ip1jmp1, llm, nqtot)
     42  REAL :: mu(ip1jmp1, llm)
     43  REAL :: mv(ip1jm, llm)
     44  REAL :: mw(ip1jmp1, llm + 1)
     45  REAL :: zq(ip1jmp1, llm, nqtot)
    4546  REAL :: zzpbar, zzw
    46   INTEGER :: ifils,iq2 ! CRisi
    47 
    48   REAL :: qmin,qmax
    49   DATA qmin,qmax/0.,1.e33/
    50 
    51     zzpbar = 0.5 * pdt
    52     zzw    = pdt
    53   DO l=1,llm
    54     DO ij = iip2,ip1jm
    55         mu(ij,l)=pbaru(ij,l) * zzpbar
    56      ENDDO
    57      DO ij=1,ip1jm
    58         mv(ij,l)=pbarv(ij,l) * zzpbar
    59      ENDDO
    60      DO ij=1,ip1jmp1
    61         mw(ij,l)=w(ij,l) * zzw
    62      ENDDO
    63   ENDDO
    64 
    65   DO ij=1,ip1jmp1
    66      mw(ij,llm+1)=0.
    67   ENDDO
    68 
    69   CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
    70   CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
    71 
    72   do ifils=1,tracers(iq)%nqDescen
    73     iq2=tracers(iq)%iqDescen(ifils)
    74     CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
    75   enddo
    76 
    77   CALL vlx(zq,pente_max,zm,mu,iq)
    78   CALL vly(zq,pente_max,zm,mv,iq)
    79   CALL vlz(zq,pente_max,zm,mw,iq)
    80   CALL vly(zq,pente_max,zm,mv,iq)
    81   CALL vlx(zq,pente_max,zm,mu,iq)
    82 
    83   DO l=1,llm
    84      DO ij=1,ip1jmp1
    85        q(ij,l,iq)=zq(ij,l,iq)
    86      ENDDO
    87      DO ij=1,ip1jm+1,iip1
    88         q(ij+iim,l,iq)=q(ij,l,iq)
    89      ENDDO
     47  INTEGER :: ifils, iq2 ! CRisi
     48
     49  REAL :: qmin, qmax
     50  DATA qmin, qmax/0., 1.e33/
     51
     52  zzpbar = 0.5 * pdt
     53  zzw = pdt
     54  DO l = 1, llm
     55    DO ij = iip2, ip1jm
     56      mu(ij, l) = pbaru(ij, l) * zzpbar
     57    ENDDO
     58    DO ij = 1, ip1jm
     59      mv(ij, l) = pbarv(ij, l) * zzpbar
     60    ENDDO
     61    DO ij = 1, ip1jmp1
     62      mw(ij, l) = w(ij, l) * zzw
     63    ENDDO
     64  ENDDO
     65
     66  DO ij = 1, ip1jmp1
     67    mw(ij, llm + 1) = 0.
     68  ENDDO
     69
     70  CALL SCOPY(ijp1llm, q(1, 1, iq), 1, zq(1, 1, iq), 1)
     71  CALL SCOPY(ijp1llm, masse, 1, zm(1, 1, iq), 1)
     72
     73  do ifils = 1, tracers(iq)%nqDescen
     74    iq2 = tracers(iq)%iqDescen(ifils)
     75    CALL SCOPY(ijp1llm, q(1, 1, iq2), 1, zq(1, 1, iq2), 1)
     76  enddo
     77
     78  CALL vlx(zq, pente_max, zm, mu, iq)
     79  CALL vly(zq, pente_max, zm, mv, iq)
     80  CALL vlz(zq, pente_max, zm, mw, iq)
     81  CALL vly(zq, pente_max, zm, mv, iq)
     82  CALL vlx(zq, pente_max, zm, mu, iq)
     83
     84  DO l = 1, llm
     85    DO ij = 1, ip1jmp1
     86      q(ij, l, iq) = zq(ij, l, iq)
     87    ENDDO
     88    DO ij = 1, ip1jm + 1, iip1
     89      q(ij + iim, l, iq) = q(ij, l, iq)
     90    ENDDO
    9091  ENDDO
    9192  ! CRisi: aussi pour les fils
    92   do ifils=1,tracers(iq)%nqDescen
    93     iq2=tracers(iq)%iqDescen(ifils)
    94     DO l=1,llm
    95       DO ij=1,ip1jmp1
    96         q(ij,l,iq2)=zq(ij,l,iq2)
    97       ENDDO
    98       DO ij=1,ip1jm+1,iip1
    99         q(ij+iim,l,iq2)=q(ij,l,iq2)
    100       ENDDO
    101     ENDDO
    102   enddo
    103 
     93  do ifils = 1, tracers(iq)%nqDescen
     94    iq2 = tracers(iq)%iqDescen(ifils)
     95    DO l = 1, llm
     96      DO ij = 1, ip1jmp1
     97        q(ij, l, iq2) = zq(ij, l, iq2)
     98      ENDDO
     99      DO ij = 1, ip1jm + 1, iip1
     100        q(ij + iim, l, iq2) = q(ij, l, iq2)
     101      ENDDO
     102    ENDDO
     103  enddo
    104104
    105105END SUBROUTINE vlsplt
    106 RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq)
    107   USE infotrac, ONLY: nqtot,tracers, & ! CRisi
    108         min_qParent,min_qMass,min_ratio ! MVals et CRisi
     106RECURSIVE SUBROUTINE vlx(q, pente_max, masse, u_m, iq)
     107  USE infotrac, ONLY: nqtot, tracers, & ! CRisi
     108          min_qParent, min_qMass, min_ratio ! MVals et CRisi
    109109  USE lmdz_iniprint, ONLY: lunout, prt_level
    110110
    … …  
    126126  !   Arguments:
    127127  !   ----------
    128   REAL :: masse(ip1jmp1,llm,nqtot),pente_max
    129   REAL :: u_m( ip1jmp1,llm )
    130   REAL :: q(ip1jmp1,llm,nqtot)
     128  REAL :: masse(ip1jmp1, llm, nqtot), pente_max
     129  REAL :: u_m(ip1jmp1, llm)
     130  REAL :: q(ip1jmp1, llm, nqtot)
    131131  INTEGER :: iq ! CRisi
    132132  !
    … …  
    134134  !   ---------
    135135  !
    136   INTEGER :: ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
    137   INTEGER :: n0,iadvplus(ip1jmp1,llm),nl(llm)
    138   !
    139   REAL :: new_m,zu_m,zdum(ip1jmp1,llm)
    140   REAL :: dxq(ip1jmp1,llm),dxqu(ip1jmp1)
     136  INTEGER :: ij, l, j, i, iju, ijq, indu(ip1jmp1), niju
     137  INTEGER :: n0, iadvplus(ip1jmp1, llm), nl(llm)
     138  !
     139  REAL :: new_m, zu_m, zdum(ip1jmp1, llm)
     140  REAL :: dxq(ip1jmp1, llm), dxqu(ip1jmp1)
    141141  REAL :: zz(ip1jmp1)
    142   REAL :: adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
    143   REAL :: u_mq(ip1jmp1,llm)
     142  REAL :: adxqu(ip1jmp1), dxqmax(ip1jmp1, llm)
     143  REAL :: u_mq(ip1jmp1, llm)
    144144
    145145  ! CRisi
    146   REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
    147   INTEGER :: ifils,iq2 ! CRisi
     146  REAL :: masseq(ip1jmp1, llm, nqtot), Ratio(ip1jmp1, llm, nqtot)
     147  INTEGER :: ifils, iq2 ! CRisi
    148148
    149149  LOGICAL, SAVE :: first
    … …  
    152152  !   calcul de la pente a droite et a gauche de la maille
    153153
    154 
    155154  IF (pente_max>-1.e-5) THEN
    156155    ! IF (pente_max.gt.10) THEN
    157156
    158   !   calcul des pentes avec limitation, Van Leer scheme I:
    159   !   -----------------------------------------------------
    160 
    161   !   calcul de la pente aux points u
    162      DO l = 1, llm
    163         DO ij=iip2,ip1jm-1
    164            dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    165         ENDDO
    166         DO ij=iip1+iip1,ip1jm,iip1
    167            dxqu(ij)=dxqu(ij-iim)
    168            ! sigu(ij)=sigu(ij-iim)
    169         ENDDO
    170 
    171         DO ij=iip2,ip1jm
    172            adxqu(ij)=abs(dxqu(ij))
    173         ENDDO
    174 
    175   !   calcul de la pente maximum dans la maille en valeur absolue
    176 
    177         DO ij=iip2+1,ip1jm
    178            dxqmax(ij,l)=pente_max* &
    179                  min(adxqu(ij-1),adxqu(ij))
    180   ! limitation subtile
    181   !    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
    182 
    183 
    184         ENDDO
    185 
    186         DO ij=iip1+iip1,ip1jm,iip1
    187            dxqmax(ij-iim,l)=dxqmax(ij,l)
    188         ENDDO
    189 
    190         DO ij=iip2+1,ip1jm
    191            IF(dxqu(ij-1)*dxqu(ij)>0) THEN
    192               dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
    193            ELSE
    194   !   extremum local
    195               dxq(ij,l)=0.
    196            ENDIF
    197            dxq(ij,l)=0.5*dxq(ij,l)
    198            dxq(ij,l)= &
    199                  sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
    200         ENDDO
    201 
    202      ENDDO ! l=1,llm
    203   !print*,'Ok calcul des pentes'
     157    !   calcul des pentes avec limitation, Van Leer scheme I:
     158    !   -----------------------------------------------------
     159
     160    !   calcul de la pente aux points u
     161    DO l = 1, llm
     162      DO ij = iip2, ip1jm - 1
     163        dxqu(ij) = q(ij + 1, l, iq) - q(ij, l, iq)
     164      ENDDO
     165      DO ij = iip1 + iip1, ip1jm, iip1
     166        dxqu(ij) = dxqu(ij - iim)
     167        ! sigu(ij)=sigu(ij-iim)
     168      ENDDO
     169
     170      DO ij = iip2, ip1jm
     171        adxqu(ij) = abs(dxqu(ij))
     172      ENDDO
     173
     174      !   calcul de la pente maximum dans la maille en valeur absolue
     175
     176      DO ij = iip2 + 1, ip1jm
     177        dxqmax(ij, l) = pente_max * &
     178                min(adxqu(ij - 1), adxqu(ij))
     179        ! limitation subtile
     180        !    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
     181
     182      ENDDO
     183
     184      DO ij = iip1 + iip1, ip1jm, iip1
     185        dxqmax(ij - iim, l) = dxqmax(ij, l)
     186      ENDDO
     187
     188      DO ij = iip2 + 1, ip1jm
     189        IF(dxqu(ij - 1) * dxqu(ij)>0) THEN
     190          dxq(ij, l) = dxqu(ij - 1) + dxqu(ij)
     191        ELSE
     192          !   extremum local
     193          dxq(ij, l) = 0.
     194        ENDIF
     195        dxq(ij, l) = 0.5 * dxq(ij, l)
     196        dxq(ij, l) = &
     197                sign(min(abs(dxq(ij, l)), dxqmax(ij, l)), dxq(ij, l))
     198      ENDDO
     199
     200    ENDDO ! l=1,llm
     201    !print*,'Ok calcul des pentes'
    204202
    205203  ELSE ! (pente_max.lt.-1.e-5)
    206204
    207   !   Pentes produits:
    208   !   ----------------
    209 
    210      DO l = 1, llm
    211         DO ij=iip2,ip1jm-1
    212            dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    213         ENDDO
    214         DO ij=iip1+iip1,ip1jm,iip1
    215            dxqu(ij)=dxqu(ij-iim)
    216         ENDDO
    217 
    218         DO ij=iip2+1,ip1jm
    219            zz(ij)=dxqu(ij-1)*dxqu(ij)
    220            zz(ij)=zz(ij)+zz(ij)
    221            IF(zz(ij)>0) THEN
    222               dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
    223            ELSE
    224   !   extremum local
    225               dxq(ij,l)=0.
    226            ENDIF
    227         ENDDO
    228 
    229      ENDDO
     205    !   Pentes produits:
     206    !   ----------------
     207
     208    DO l = 1, llm
     209      DO ij = iip2, ip1jm - 1
     210        dxqu(ij) = q(ij + 1, l, iq) - q(ij, l, iq)
     211      ENDDO
     212      DO ij = iip1 + iip1, ip1jm, iip1
     213        dxqu(ij) = dxqu(ij - iim)
     214      ENDDO
     215
     216      DO ij = iip2 + 1, ip1jm
     217        zz(ij) = dxqu(ij - 1) * dxqu(ij)
     218        zz(ij) = zz(ij) + zz(ij)
     219        IF(zz(ij)>0) THEN
     220          dxq(ij, l) = zz(ij) / (dxqu(ij - 1) + dxqu(ij))
     221        ELSE
     222          !   extremum local
     223          dxq(ij, l) = 0.
     224        ENDIF
     225      ENDDO
     226
     227    ENDDO
    230228
    231229  ENDIF ! (pente_max.lt.-1.e-5)
    … …  
    234232  !   -----------------------------
    235233
    236   DO l=1,llm
    237      DO ij=iip1+iip1,ip1jm,iip1
    238         dxq(ij-iim,l)=dxq(ij,l)
    239      ENDDO
    240      DO ij=1,ip1jmp1
    241         iadvplus(ij,l)=0
    242      ENDDO
     234  DO l = 1, llm
     235    DO ij = iip1 + iip1, ip1jm, iip1
     236      dxq(ij - iim, l) = dxq(ij, l)
     237    ENDDO
     238    DO ij = 1, ip1jmp1
     239      iadvplus(ij, l) = 0
     240    ENDDO
    243241
    244242  ENDDO
    … …  
    247245  !   on cumule le flux correspondant a toutes les mailles dont la masse
    248246  !   au travers de la paroi pENDant le pas de temps.
    249   DO l=1,llm
    250    DO ij=iip2,ip1jm-1
    251       IF (u_m(ij,l)>0.) THEN
    252          zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
    253          u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l))
     247  DO l = 1, llm
     248    DO ij = iip2, ip1jm - 1
     249      IF (u_m(ij, l)>0.) THEN
     250        zdum(ij, l) = 1. - u_m(ij, l) / masse(ij, l, iq)
     251        u_mq(ij, l) = u_m(ij, l) * (q(ij, l, iq) + 0.5 * zdum(ij, l) * dxq(ij, l))
    254252      ELSE
    255          zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
    256          u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq) &
    257                -0.5*zdum(ij,l)*dxq(ij+1,l))
     253        zdum(ij, l) = 1. + u_m(ij, l) / masse(ij + 1, l, iq)
     254        u_mq(ij, l) = u_m(ij, l) * (q(ij + 1, l, iq) &
     255                - 0.5 * zdum(ij, l) * dxq(ij + 1, l))
    258256      ENDIF
    259    ENDDO
     257    ENDDO
    260258  ENDDO
    261259
    262260  !   detection des points ou on advecte plus que la masse de la
    263261  !   maille
    264   DO l=1,llm
    265      DO ij=iip2,ip1jm-1
    266         IF(zdum(ij,l)<0) THEN
    267            iadvplus(ij,l)=1
    268            u_mq(ij,l)=0.
    269         ENDIF
    270      ENDDO
    271   ENDDO
    272   DO l=1,llm
    273    DO ij=iip1+iip1,ip1jm,iip1
    274       iadvplus(ij,l)=iadvplus(ij-iim,l)
    275    ENDDO
     262  DO l = 1, llm
     263    DO ij = iip2, ip1jm - 1
     264      IF(zdum(ij, l)<0) THEN
     265        iadvplus(ij, l) = 1
     266        u_mq(ij, l) = 0.
     267      ENDIF
     268    ENDDO
     269  ENDDO
     270  DO l = 1, llm
     271    DO ij = iip1 + iip1, ip1jm, iip1
     272      iadvplus(ij, l) = iadvplus(ij - iim, l)
     273    ENDDO
    276274  ENDDO
    277275
    … …  
    283281  !  calcul du nombre de maille sur lequel on advecte plus que la maille.
    284282
    285   n0=0
    286   DO l=1,llm
    287      nl(l)=0
    288      DO ij=iip2,ip1jm
    289         nl(l)=nl(l)+iadvplus(ij,l)
    290      ENDDO
    291      n0=n0+nl(l)
     283  n0 = 0
     284  DO l = 1, llm
     285    nl(l) = 0
     286    DO ij = iip2, ip1jm
     287      nl(l) = nl(l) + iadvplus(ij, l)
     288    ENDDO
     289    n0 = n0 + nl(l)
    292290  ENDDO
    293291
    294292  IF(n0>0) THEN
    295   IF (prt_level > 2) PRINT *, &
    296         'Nombre de points pour lesquels on advect plus que le' &
    297         ,'contenu de la maille : ',n0
    298 
    299      DO l=1,llm
    300         IF(nl(l)>0) THEN
    301            iju=0
    302   !   indicage des mailles concernees par le traitement special
    303            DO ij=iip2,ip1jm
    304               IF(iadvplus(ij,l)==1.AND.mod(ij,iip1)/=0) THEN
    305                  iju=iju+1
    306                  indu(iju)=ij
    307               ENDIF
    308            ENDDO
    309            niju=iju
    310 
    311   !  traitement des mailles
    312            DO iju=1,niju
    313               ij=indu(iju)
    314               j=(ij-1)/iip1+1
    315               zu_m=u_m(ij,l)
    316               u_mq(ij,l)=0.
    317               IF(zu_m>0.) THEN
    318                  ijq=ij
    319                  i=ijq-(j-1)*iip1
    320   !   accumulation pour les mailles completements advectees
    321                  do while(zu_m>masse(ijq,l,iq))
    322                     u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq) &
    323                           *masse(ijq,l,iq)
    324                     zu_m=zu_m-masse(ijq,l,iq)
    325                     i=mod(i-2+iim,iim)+1
    326                     ijq=(j-1)*iip1+i
    327                  ENDDO
    328   !   ajout de la maille non completement advectee
    329                  u_mq(ij,l)=u_mq(ij,l)+zu_m* &
    330                        (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq)) &
    331                        *dxq(ijq,l))
    332               ELSE
    333                  ijq=ij+1
    334                  i=ijq-(j-1)*iip1
    335   !   accumulation pour les mailles completements advectees
    336                  do while(-zu_m>masse(ijq,l,iq))
    337                     u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq) &
    338                           *masse(ijq,l,iq)
    339                     zu_m=zu_m+masse(ijq,l,iq)
    340                     i=mod(i,iim)+1
    341                     ijq=(j-1)*iip1+i
    342                  ENDDO
    343   !   ajout de la maille non completement advectee
    344                  u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)- &
    345                        0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    346               ENDIF
    347            ENDDO
    348         ENDIF
    349      ENDDO
     293    IF (prt_level > 2) PRINT *, &
     294            'Nombre de points pour lesquels on advect plus que le' &
     295            , 'contenu de la maille : ', n0
     296
     297    DO l = 1, llm
     298      IF(nl(l)>0) THEN
     299        iju = 0
     300        !   indicage des mailles concernees par le traitement special
     301        DO ij = iip2, ip1jm
     302          IF(iadvplus(ij, l)==1.AND.mod(ij, iip1)/=0) THEN
     303            iju = iju + 1
     304            indu(iju) = ij
     305          ENDIF
     306        ENDDO
     307        niju = iju
     308
     309        !  traitement des mailles
     310        DO iju = 1, niju
     311          ij = indu(iju)
     312          j = (ij - 1) / iip1 + 1
     313          zu_m = u_m(ij, l)
     314          u_mq(ij, l) = 0.
     315          IF(zu_m>0.) THEN
     316            ijq = ij
     317            i = ijq - (j - 1) * iip1
     318            !   accumulation pour les mailles completements advectees
     319            do while(zu_m>masse(ijq, l, iq))
     320              u_mq(ij, l) = u_mq(ij, l) + q(ijq, l, iq) &
     321                      * masse(ijq, l, iq)
     322              zu_m = zu_m - masse(ijq, l, iq)
     323              i = mod(i - 2 + iim, iim) + 1
     324              ijq = (j - 1) * iip1 + i
     325            ENDDO
     326            !   ajout de la maille non completement advectee
     327            u_mq(ij, l) = u_mq(ij, l) + zu_m * &
     328                    (q(ijq, l, iq) + 0.5 * (1. - zu_m / masse(ijq, l, iq)) &
     329                            * dxq(ijq, l))
     330          ELSE
     331            ijq = ij + 1
     332            i = ijq - (j - 1) * iip1
     333            !   accumulation pour les mailles completements advectees
     334            do while(-zu_m>masse(ijq, l, iq))
     335              u_mq(ij, l) = u_mq(ij, l) - q(ijq, l, iq) &
     336                      * masse(ijq, l, iq)
     337              zu_m = zu_m + masse(ijq, l, iq)
     338              i = mod(i, iim) + 1
     339              ijq = (j - 1) * iip1 + i
     340            ENDDO
     341            !   ajout de la maille non completement advectee
     342            u_mq(ij, l) = u_mq(ij, l) + zu_m * (q(ijq, l, iq) - &
     343                    0.5 * (1. + zu_m / masse(ijq, l, iq)) * dxq(ijq, l))
     344          ENDIF
     345        ENDDO
     346      ENDIF
     347    ENDDO
    350348  ENDIF  ! n0.gt.0
    351349
    … …  
    353351  !   bouclage en latitude
    354352  !print*,'cvant bouclage en latitude'
    355   DO l=1,llm
    356     DO ij=iip1+iip1,ip1jm,iip1
    357        u_mq(ij,l)=u_mq(ij-iim,l)
     353  DO l = 1, llm
     354    DO ij = iip1 + iip1, ip1jm, iip1
     355      u_mq(ij, l) = u_mq(ij - iim, l)
    358356    ENDDO
    359357  ENDDO
    … …  
    363361  !WRITE(*,*) 'vlsplt 326: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen
    364362
    365   do ifils=1,tracers(iq)%nqDescen
    366     iq2=tracers(iq)%iqDescen(ifils)
    367     DO l=1,llm
    368       DO ij=iip2,ip1jm
     363  do ifils = 1, tracers(iq)%nqDescen
     364    iq2 = tracers(iq)%iqDescen(ifils)
     365    DO l = 1, llm
     366      DO ij = iip2, ip1jm
    369367        ! On a besoin de q et masse seulement entre iip2 et ip1jm
    370368        !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
    371   !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     369        !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    372370        !Mvals: veiller a ce qu'on n'ait pas de denominateur nul
    373         masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    374         IF (q(ij,l,iq)>min_qParent) THEN
    375           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     371        masseq(ij, l, iq2) = max(masse(ij, l, iq) * q(ij, l, iq), min_qMass)
     372        IF (q(ij, l, iq)>min_qParent) THEN
     373          Ratio(ij, l, iq2) = q(ij, l, iq2) / q(ij, l, iq)
    376374        else
    377           Ratio(ij,l,iq2)=min_ratio
     375          Ratio(ij, l, iq2) = min_ratio
    378376        endif
    379377      enddo
    380378    enddo
    381379  enddo
    382   do ifils=1,tracers(iq)%nqChildren
    383     iq2=tracers(iq)%iqDescen(ifils)
    384     CALL vlx(Ratio,pente_max,masseq,u_mq,iq2)
     380  do ifils = 1, tracers(iq)%nqChildren
     381    iq2 = tracers(iq)%iqDescen(ifils)
     382    CALL vlx(Ratio, pente_max, masseq, u_mq, iq2)
    385383  enddo
    386384  ! end CRisi
    … …  
    389387  !   calcul des tENDances
    390388
    391   DO l=1,llm
    392      DO ij=iip2+1,ip1jm
    393         !MVals: veiller a ce qu'on ait pas de denominateur nul
    394         new_m=max(masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l),min_qMass)
    395         q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+ &
    396               u_mq(ij-1,l)-u_mq(ij,l)) &
    397               /new_m
    398         masse(ij,l,iq)=new_m
    399      ENDDO
    400      DO ij=iip1+iip1,ip1jm,iip1
    401         q(ij-iim,l,iq)=q(ij,l,iq)
    402         masse(ij-iim,l,iq)=masse(ij,l,iq)
    403      ENDDO
     389  DO l = 1, llm
     390    DO ij = iip2 + 1, ip1jm
     391      !MVals: veiller a ce qu'on ait pas de denominateur nul
     392      new_m = max(masse(ij, l, iq) + u_m(ij - 1, l) - u_m(ij, l), min_qMass)
     393      q(ij, l, iq) = (q(ij, l, iq) * masse(ij, l, iq) + &
     394              u_mq(ij - 1, l) - u_mq(ij, l)) &
     395              / new_m
     396      masse(ij, l, iq) = new_m
     397    ENDDO
     398    DO ij = iip1 + iip1, ip1jm, iip1
     399      q(ij - iim, l, iq) = q(ij, l, iq)
     400      masse(ij - iim, l, iq) = masse(ij, l, iq)
     401    ENDDO
    404402  ENDDO
    405403
    … …  
    407405  ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
    408406  ! puis on boucle en longitude
    409   do ifils=1,tracers(iq)%nqDescen
    410     iq2=tracers(iq)%iqDescen(ifils)
    411     DO l=1,llm
    412       DO ij=iip2+1,ip1jm
    413         q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
     407  do ifils = 1, tracers(iq)%nqDescen
     408    iq2 = tracers(iq)%iqDescen(ifils)
     409    DO l = 1, llm
     410      DO ij = iip2 + 1, ip1jm
     411        q(ij, l, iq2) = q(ij, l, iq) * Ratio(ij, l, iq2)
    414412      enddo
    415       DO ij=iip1+iip1,ip1jm,iip1
    416          q(ij-iim,l,iq2)=q(ij,l,iq2)
     413      DO ij = iip1 + iip1, ip1jm, iip1
     414        q(ij - iim, l, iq2) = q(ij, l, iq2)
    417415      enddo ! DO ij=ijb+iip1-1,ije,iip1
    418416    enddo !DO l=1,llm
    419417  enddo
    420418
    421 
    422419END SUBROUTINE vlx
    423 RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq)
    424   USE infotrac, ONLY: nqtot,tracers, & ! CRisi
    425         min_qParent,min_qMass,min_ratio ! MVals et CRisi
     420RECURSIVE SUBROUTINE vly(q, pente_max, masse, masse_adv_v, iq)
     421  USE infotrac, ONLY: nqtot, tracers, & ! CRisi
     422          min_qParent, min_qMass, min_ratio ! MVals et CRisi
    426423  !
    427424  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    445442  !   Arguments:
    446443  !   ----------
    447   REAL :: masse(ip1jmp1,llm,nqtot),pente_max
    448   REAL :: masse_adv_v( ip1jm,llm)
    449   REAL :: q(ip1jmp1,llm,nqtot)
     444  REAL :: masse(ip1jmp1, llm, nqtot), pente_max
     445  REAL :: masse_adv_v(ip1jm, llm)
     446  REAL :: q(ip1jmp1, llm, nqtot)
    450447  INTEGER :: iq ! CRisi
    451448  !
    … …  
    453450  !   ---------
    454451  !
    455   INTEGER :: i,ij,l
    456   !
    457   REAL :: airej2,airejjm,airescb(iim),airesch(iim)
    458   REAL :: dyq(ip1jmp1,llm),dyqv(ip1jm)
    459   REAL :: adyqv(ip1jm),dyqmax(ip1jmp1)
    460   REAL :: qbyv(ip1jm,llm)
    461 
    462   REAL :: qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
     452  INTEGER :: i, ij, l
     453  !
     454  REAL :: airej2, airejjm, airescb(iim), airesch(iim)
     455  REAL :: dyq(ip1jmp1, llm), dyqv(ip1jm)
     456  REAL :: adyqv(ip1jm), dyqmax(ip1jmp1)
     457  REAL :: qbyv(ip1jm, llm)
     458
     459  REAL :: qpns, qpsn, dyn1, dys1, dyn2, dys2, newmasse, fn, fs
    463460  LOGICAL, SAVE :: first
    464461
    465   REAL :: convpn,convps,convmpn,convmps
    466   REAL :: massepn,masseps,qpn,qps
    467   REAL :: sinlon(iip1),sinlondlon(iip1)
    468   REAL :: coslon(iip1),coslondlon(iip1)
    469   SAVE sinlon,coslon,sinlondlon,coslondlon
    470   SAVE airej2,airejjm
    471 
    472   REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
    473   INTEGER :: ifils,iq2 ! CRisi
     462  REAL :: convpn, convps, convmpn, convmps
     463  REAL :: massepn, masseps, qpn, qps
     464  REAL :: sinlon(iip1), sinlondlon(iip1)
     465  REAL :: coslon(iip1), coslondlon(iip1)
     466  SAVE sinlon, coslon, sinlondlon, coslondlon
     467  SAVE airej2, airejjm
     468
     469  REAL :: masseq(ip1jmp1, llm, nqtot), Ratio(ip1jmp1, llm, nqtot) ! CRisi
     470  INTEGER :: ifils, iq2 ! CRisi
    474471
    475472  !
    … …  
    482479
    483480  IF(first) THEN
    484      PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
    485      first=.FALSE.
    486      do i=2,iip1
    487         coslon(i)=cos(rlonv(i))
    488         sinlon(i)=sin(rlonv(i))
    489         coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
    490         sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
    491      ENDDO
    492      coslon(1)=coslon(iip1)
    493      coslondlon(1)=coslondlon(iip1)
    494      sinlon(1)=sinlon(iip1)
    495      sinlondlon(1)=sinlondlon(iip1)
    496      airej2 = SSUM( iim, aire(iip2), 1 )
    497      airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
     481    PRINT*, 'Shema  Amont nouveau  appele dans  Vanleer   '
     482    first = .FALSE.
     483    do i = 2, iip1
     484      coslon(i) = cos(rlonv(i))
     485      sinlon(i) = sin(rlonv(i))
     486      coslondlon(i) = coslon(i) * (rlonu(i) - rlonu(i - 1)) / pi
     487      sinlondlon(i) = sinlon(i) * (rlonu(i) - rlonu(i - 1)) / pi
     488    ENDDO
     489    coslon(1) = coslon(iip1)
     490    coslondlon(1) = coslondlon(iip1)
     491    sinlon(1) = sinlon(iip1)
     492    sinlondlon(1) = sinlondlon(iip1)
     493    airej2 = SSUM(iim, aire(iip2), 1)
     494    airejjm = SSUM(iim, aire(ip1jm - iim), 1)
    498495  ENDIF
    499496
    … …  
    502499
    503500  DO l = 1, llm
    504   !
    505   !   --------------------------------
    506   !  CALCUL EN LATITUDE
    507   !   --------------------------------
    508 
    509   !   On commence par calculer la valeur du traceur moyenne sur le premier cercle
    510   !   de latitude autour du pole (qpns pour le pole nord et qpsn pour
    511   !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
    512 
    513   DO i = 1, iim
    514   airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
    515   airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
    516   ENDDO
    517   qpns   = SSUM( iim,  airescb ,1 ) / airej2
    518   qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
    519 
    520   !   calcul des pentes aux points v
    521 
    522   DO ij=1,ip1jm
    523      dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
    524      adyqv(ij)=abs(dyqv(ij))
    525   ENDDO
    526 
    527   !   calcul des pentes aux points scalaires
    528 
    529   DO ij=iip2,ip1jm
    530      dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
    531      dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
    532      dyqmax(ij)=pente_max*dyqmax(ij)
    533   ENDDO
    534 
    535   !   calcul des pentes aux poles
    536 
    537   DO ij=1,iip1
    538      dyq(ij,l)=qpns-q(ij+iip1,l,iq)
    539      dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
    540   ENDDO
    541 
    542   !   filtrage de la derivee
    543   dyn1=0.
    544   dys1=0.
    545   dyn2=0.
    546   dys2=0.
    547   DO ij=1,iim
    548      dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
    549      dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
    550      dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
    551      dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
    552   ENDDO
    553   DO ij=1,iip1
    554      dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
    555      dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
    556   ENDDO
    557 
    558   !   calcul des pentes limites aux poles
    559 
    560   goto 8888
    561   fn=1.
    562   fs=1.
    563   DO ij=1,iim
    564      IF(pente_max*adyqv(ij)<abs(dyq(ij,l))) THEN
    565         fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
    566      ENDIF
    567   IF(pente_max*adyqv(ij+ip1jm-iip1)<abs(dyq(ij+ip1jm,l))) THEN
    568      fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
    569      ENDIF
    570   ENDDO
    571   DO ij=1,iip1
    572      dyq(ij,l)=fn*dyq(ij,l)
    573      dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
    574   ENDDO
    575 8888   continue
    576   DO ij=1,iip1
    577      dyq(ij,l)=0.
    578      dyq(ip1jm+ij,l)=0.
    579   ENDDO
    580 
    581   !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    582   !  En memoire de dIFferents tests sur la
    583   !  limitation des pentes aux poles.
    584   !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    585   ! PRINT*,dyq(1)
    586   ! PRINT*,dyqv(iip1+1)
    587   ! appn=abs(dyq(1)/dyqv(iip1+1))
    588   ! PRINT*,dyq(ip1jm+1)
    589   ! PRINT*,dyqv(ip1jm-iip1+1)
    590   ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
    591   ! DO ij=2,iim
    592   !    appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
    593   !    apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
    594   ! ENDDO
    595   ! appn=min(pente_max/appn,1.)
    596   ! apps=min(pente_max/apps,1.)
    597   !
    598   !
    599   !   cas ou on a un extremum au pole
    600   !
    601   ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
    602   !    &   appn=0.
    603   ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
    604   !    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
    605   !    &   apps=0.
    606   !
    607   !   limitation des pentes aux poles
    608   ! DO ij=1,iip1
    609   !    dyq(ij)=appn*dyq(ij)
    610   !    dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
    611   ! ENDDO
    612   !
    613   !   test
    614   !  DO ij=1,iip1
    615   !     dyq(iip1+ij)=0.
    616   !     dyq(ip1jm+ij-iip1)=0.
    617   !  ENDDO
    618   !  DO ij=1,ip1jmp1
    619   !     dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
    620   !  ENDDO
    621   !
    622   ! changement 10 07 96
    623   ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
    624   !    &   THEN
    625   !    DO ij=1,iip1
    626   !       dyqmax(ij)=0.
    627   !    ENDDO
    628   ! ELSE
    629   !    DO ij=1,iip1
    630   !       dyqmax(ij)=pente_max*abs(dyqv(ij))
    631   !    ENDDO
    632   ! ENDIF
    633   !
    634   ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
    635   !    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
    636   !    &THEN
    637   !    DO ij=ip1jm+1,ip1jmp1
    638   !       dyqmax(ij)=0.
    639   !    ENDDO
    640   ! ELSE
    641   !    DO ij=ip1jm+1,ip1jmp1
    642   !       dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
    643   !    ENDDO
    644   ! ENDIF
    645   !   fin changement 10 07 96
    646   !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    647 
    648   !   calcul des pentes limitees
    649 
    650   DO ij=iip2,ip1jm
    651      IF(dyqv(ij)*dyqv(ij-iip1)>0.) THEN
    652         dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
    653      ELSE
    654         dyq(ij,l)=0.
    655      ENDIF
    656   ENDDO
     501    !
     502    !   --------------------------------
     503    !  CALCUL EN LATITUDE
     504    !   --------------------------------
     505
     506    !   On commence par calculer la valeur du traceur moyenne sur le premier cercle
     507    !   de latitude autour du pole (qpns pour le pole nord et qpsn pour
     508    !    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
     509
     510    DO i = 1, iim
     511      airescb(i) = aire(i + iip1) * q(i + iip1, l, iq)
     512      airesch(i) = aire(i + ip1jm - iip1) * q(i + ip1jm - iip1, l, iq)
     513    ENDDO
     514    qpns = SSUM(iim, airescb, 1) / airej2
     515    qpsn = SSUM(iim, airesch, 1) / airejjm
     516
     517    !   calcul des pentes aux points v
     518
     519    DO ij = 1, ip1jm
     520      dyqv(ij) = q(ij, l, iq) - q(ij + iip1, l, iq)
     521      adyqv(ij) = abs(dyqv(ij))
     522    ENDDO
     523
     524    !   calcul des pentes aux points scalaires
     525
     526    DO ij = iip2, ip1jm
     527      dyq(ij, l) = .5 * (dyqv(ij - iip1) + dyqv(ij))
     528      dyqmax(ij) = min(adyqv(ij - iip1), adyqv(ij))
     529      dyqmax(ij) = pente_max * dyqmax(ij)
     530    ENDDO
     531
     532    !   calcul des pentes aux poles
     533
     534    DO ij = 1, iip1
     535      dyq(ij, l) = qpns - q(ij + iip1, l, iq)
     536      dyq(ip1jm + ij, l) = q(ip1jm + ij - iip1, l, iq) - qpsn
     537    ENDDO
     538
     539    !   filtrage de la derivee
     540    dyn1 = 0.
     541    dys1 = 0.
     542    dyn2 = 0.
     543    dys2 = 0.
     544    DO ij = 1, iim
     545      dyn1 = dyn1 + sinlondlon(ij) * dyq(ij, l)
     546      dys1 = dys1 + sinlondlon(ij) * dyq(ip1jm + ij, l)
     547      dyn2 = dyn2 + coslondlon(ij) * dyq(ij, l)
     548      dys2 = dys2 + coslondlon(ij) * dyq(ip1jm + ij, l)
     549    ENDDO
     550    DO ij = 1, iip1
     551      dyq(ij, l) = dyn1 * sinlon(ij) + dyn2 * coslon(ij)
     552      dyq(ip1jm + ij, l) = dys1 * sinlon(ij) + dys2 * coslon(ij)
     553    ENDDO
     554
     555    !   calcul des pentes limites aux poles
     556
     557    goto 8888
     558    fn = 1.
     559    fs = 1.
     560    DO ij = 1, iim
     561      IF(pente_max * adyqv(ij)<abs(dyq(ij, l))) THEN
     562        fn = min(pente_max * adyqv(ij) / abs(dyq(ij, l)), fn)
     563      ENDIF
     564      IF(pente_max * adyqv(ij + ip1jm - iip1)<abs(dyq(ij + ip1jm, l))) THEN
     565        fs = min(pente_max * adyqv(ij + ip1jm - iip1) / abs(dyq(ij + ip1jm, l)), fs)
     566      ENDIF
     567    ENDDO
     568    DO ij = 1, iip1
     569      dyq(ij, l) = fn * dyq(ij, l)
     570      dyq(ip1jm + ij, l) = fs * dyq(ip1jm + ij, l)
     571    ENDDO
     572    8888   continue
     573    DO ij = 1, iip1
     574      dyq(ij, l) = 0.
     575      dyq(ip1jm + ij, l) = 0.
     576    ENDDO
     577
     578    !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     579    !  En memoire de dIFferents tests sur la
     580    !  limitation des pentes aux poles.
     581    !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     582    ! PRINT*,dyq(1)
     583    ! PRINT*,dyqv(iip1+1)
     584    ! appn=abs(dyq(1)/dyqv(iip1+1))
     585    ! PRINT*,dyq(ip1jm+1)
     586    ! PRINT*,dyqv(ip1jm-iip1+1)
     587    ! apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
     588    ! DO ij=2,iim
     589    !    appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
     590    !    apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
     591    ! ENDDO
     592    ! appn=min(pente_max/appn,1.)
     593    ! apps=min(pente_max/apps,1.)
     594    !
     595    !
     596    !   cas ou on a un extremum au pole
     597    !
     598    ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
     599    !    &   appn=0.
     600    ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
     601    !    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
     602    !    &   apps=0.
     603    !
     604    !   limitation des pentes aux poles
     605    ! DO ij=1,iip1
     606    !    dyq(ij)=appn*dyq(ij)
     607    !    dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
     608    ! ENDDO
     609    !
     610    !   test
     611    !  DO ij=1,iip1
     612    !     dyq(iip1+ij)=0.
     613    !     dyq(ip1jm+ij-iip1)=0.
     614    !  ENDDO
     615    !  DO ij=1,ip1jmp1
     616    !     dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
     617    !  ENDDO
     618    !
     619    ! changement 10 07 96
     620    ! IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
     621    !    &   THEN
     622    !    DO ij=1,iip1
     623    !       dyqmax(ij)=0.
     624    !    ENDDO
     625    ! ELSE
     626    !    DO ij=1,iip1
     627    !       dyqmax(ij)=pente_max*abs(dyqv(ij))
     628    !    ENDDO
     629    ! ENDIF
     630    !
     631    ! IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
     632    !    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
     633    !    &THEN
     634    !    DO ij=ip1jm+1,ip1jmp1
     635    !       dyqmax(ij)=0.
     636    !    ENDDO
     637    ! ELSE
     638    !    DO ij=ip1jm+1,ip1jmp1
     639    !       dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
     640    !    ENDDO
     641    ! ENDIF
     642    !   fin changement 10 07 96
     643    !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
     644
     645    !   calcul des pentes limitees
     646
     647    DO ij = iip2, ip1jm
     648      IF(dyqv(ij) * dyqv(ij - iip1)>0.) THEN
     649        dyq(ij, l) = sign(min(abs(dyq(ij, l)), dyqmax(ij)), dyq(ij, l))
     650      ELSE
     651        dyq(ij, l) = 0.
     652      ENDIF
     653    ENDDO
    657654
    658655  ENDDO
    659656
    660657  ! !WRITE(*,*) 'vly 756'
    661   DO l=1,llm
    662    DO ij=1,ip1jm
    663       IF(masse_adv_v(ij,l)>0) THEN
    664           qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)* &
    665                 0.5*(1.-masse_adv_v(ij,l) &
    666                 /masse(ij+iip1,l,iq))
     658  DO l = 1, llm
     659    DO ij = 1, ip1jm
     660      IF(masse_adv_v(ij, l)>0) THEN
     661        qbyv(ij, l) = q(ij + iip1, l, iq) + dyq(ij + iip1, l) * &
     662                0.5 * (1. - masse_adv_v(ij, l) &
     663                / masse(ij + iip1, l, iq))
    667664      ELSE
    668           qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)* &
    669                 0.5*(1.+masse_adv_v(ij,l) &
    670                 /masse(ij,l,iq))
     665        qbyv(ij, l) = q(ij, l, iq) - dyq(ij, l) * &
     666                0.5 * (1. + masse_adv_v(ij, l) &
     667                / masse(ij, l, iq))
    671668      ENDIF
    672       qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
    673    ENDDO
     669      qbyv(ij, l) = masse_adv_v(ij, l) * qbyv(ij, l)
     670    ENDDO
    674671  ENDDO
    675672
    676673  ! CRisi: appel récursif de l'advection sur les fils.
    677674  ! Il faut faire ça avant d'avoir mis à jour q et masse
    678    ! WRITE(*,*) 'vly 689: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen
    679 
    680   do ifils=1,tracers(iq)%nqDescen
    681     iq2=tracers(iq)%iqDescen(ifils)
    682     DO l=1,llm
    683       DO ij=1,ip1jmp1
     675  ! WRITE(*,*) 'vly 689: iq,nqDesc(iq)=',iq,tracers(iq)%nqDescen
     676
     677  do ifils = 1, tracers(iq)%nqDescen
     678    iq2 = tracers(iq)%iqDescen(ifils)
     679    DO l = 1, llm
     680      DO ij = 1, ip1jmp1
    684681        ! ! attention, chaque fils doit avoir son masseq, sinon, le 1er
    685682        ! ! fils ecrase le masseq de ses freres.
    686683        ! !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
    687   !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     684        !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    688685        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    689         masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    690         IF (q(ij,l,iq)>min_qParent) THEN
    691           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     686        masseq(ij, l, iq2) = max(masse(ij, l, iq) * q(ij, l, iq), min_qMass)
     687        IF (q(ij, l, iq)>min_qParent) THEN
     688          Ratio(ij, l, iq2) = q(ij, l, iq2) / q(ij, l, iq)
    692689        else
    693           Ratio(ij,l,iq2)=min_ratio
     690          Ratio(ij, l, iq2) = min_ratio
    694691        endif
    695692      enddo
    … …  
    697694  enddo
    698695
    699   do ifils=1,tracers(iq)%nqDescen
    700     iq2=tracers(iq)%iqDescen(ifils)
    701     CALL vly(Ratio,pente_max,masseq,qbyv,iq2)
    702   enddo
    703 
    704   DO l=1,llm
    705      DO ij=iip2,ip1jm
    706         newmasse=masse(ij,l,iq) &
    707               +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
    708         q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l) &
    709               -qbyv(ij-iip1,l))/newmasse
    710         masse(ij,l,iq)=newmasse
    711      ENDDO
    712      convpn=SSUM(iim,qbyv(1,l),1)
    713      convmpn=ssum(iim,masse_adv_v(1,l),1)
    714      massepn=ssum(iim,masse(1,l,iq),1)
    715      qpn=0.
    716      do ij=1,iim
    717         qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
    718      enddo
    719      qpn=(qpn+convpn)/(massepn+convmpn)
    720      do ij=1,iip1
    721         q(ij,l,iq)=qpn
    722      enddo
    723      convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    724      convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
    725      masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
    726      qps=0.
    727      do ij = ip1jm+1,ip1jmp1-1
    728         qps=qps+masse(ij,l,iq)*q(ij,l,iq)
    729      enddo
    730      qps=(qps+convps)/(masseps+convmps)
    731      do ij=ip1jm+1,ip1jmp1
    732         q(ij,l,iq)=qps
    733      enddo
     696  do ifils = 1, tracers(iq)%nqDescen
     697    iq2 = tracers(iq)%iqDescen(ifils)
     698    CALL vly(Ratio, pente_max, masseq, qbyv, iq2)
     699  enddo
     700
     701  DO l = 1, llm
     702    DO ij = iip2, ip1jm
     703      newmasse = masse(ij, l, iq) &
     704              + masse_adv_v(ij, l) - masse_adv_v(ij - iip1, l)
     705      q(ij, l, iq) = (q(ij, l, iq) * masse(ij, l, iq) + qbyv(ij, l) &
     706              - qbyv(ij - iip1, l)) / newmasse
     707      masse(ij, l, iq) = newmasse
     708    ENDDO
     709    convpn = SSUM(iim, qbyv(1, l), 1)
     710    convmpn = ssum(iim, masse_adv_v(1, l), 1)
     711    massepn = ssum(iim, masse(1, l, iq), 1)
     712    qpn = 0.
     713    do ij = 1, iim
     714      qpn = qpn + masse(ij, l, iq) * q(ij, l, iq)
     715    enddo
     716    qpn = (qpn + convpn) / (massepn + convmpn)
     717    do ij = 1, iip1
     718      q(ij, l, iq) = qpn
     719    enddo
     720    convps = -SSUM(iim, qbyv(ip1jm - iim, l), 1)
     721    convmps = -ssum(iim, masse_adv_v(ip1jm - iim, l), 1)
     722    masseps = ssum(iim, masse(ip1jm + 1, l, iq), 1)
     723    qps = 0.
     724    do ij = ip1jm + 1, ip1jmp1 - 1
     725      qps = qps + masse(ij, l, iq) * q(ij, l, iq)
     726    enddo
     727    qps = (qps + convps) / (masseps + convmps)
     728    do ij = ip1jm + 1, ip1jmp1
     729      q(ij, l, iq) = qps
     730    enddo
    734731  ENDDO
    735732
    736733  ! retablir les fils en rapport de melange par rapport a l'air:
    737   do ifils=1,tracers(iq)%nqDescen
    738     iq2=tracers(iq)%iqDescen(ifils)
    739     DO l=1,llm
    740       DO ij=1,ip1jmp1
    741         q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
     734  do ifils = 1, tracers(iq)%nqDescen
     735    iq2 = tracers(iq)%iqDescen(ifils)
     736    DO l = 1, llm
     737      DO ij = 1, ip1jmp1
     738        q(ij, l, iq2) = q(ij, l, iq) * Ratio(ij, l, iq2)
    742739      enddo
    743740    enddo
    … …  
    746743  ! !WRITE(*,*) 'vly 853: sortie'
    747744
    748 
    749745END SUBROUTINE vly
    750 RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq)
    751   USE infotrac, ONLY: nqtot,tracers, & ! CRisi
    752         min_qParent,min_qMass,min_ratio ! MVals et CRisi
     746RECURSIVE SUBROUTINE vlz(q, pente_max, masse, w, iq)
     747  USE infotrac, ONLY: nqtot, tracers, & ! CRisi
     748          min_qParent, min_qMass, min_ratio ! MVals et CRisi
    753749  !
    754750  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    768764  !   Arguments:
    769765  !   ----------
    770   REAL :: masse(ip1jmp1,llm,nqtot),pente_max
    771   REAL :: q(ip1jmp1,llm,nqtot)
    772   REAL :: w(ip1jmp1,llm+1)
     766  REAL :: masse(ip1jmp1, llm, nqtot), pente_max
     767  REAL :: q(ip1jmp1, llm, nqtot)
     768  REAL :: w(ip1jmp1, llm + 1)
    773769  INTEGER :: iq
    774770  !
    … …  
    776772  !   ---------
    777773  !
    778   INTEGER :: ij,l
    779   !
    780   REAL :: wq(ip1jmp1,llm+1),newmasse
    781 
    782   REAL :: dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax
     774  INTEGER :: ij, l
     775  !
     776  REAL :: wq(ip1jmp1, llm + 1), newmasse
     777
     778  REAL :: dzq(ip1jmp1, llm), dzqw(ip1jmp1, llm), adzqw(ip1jmp1, llm), dzqmax
    783779  REAL :: sigw
    784780
    785   REAL :: masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
    786   INTEGER :: ifils,iq2 ! CRisi
     781  REAL :: masseq(ip1jmp1, llm, nqtot), Ratio(ip1jmp1, llm, nqtot) ! CRisi
     782  INTEGER :: ifils, iq2 ! CRisi
    787783
    788784#ifdef BIDON
    … …  
    795791  !    On oriente tout dans le sens de la pression c'est a dire dans le
    796792  !    sens de W
    797   DO l=2,llm
    798      DO ij=1,ip1jmp1
    799         dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
    800         adzqw(ij,l)=abs(dzqw(ij,l))
    801      ENDDO
    802   ENDDO
    803 
    804   DO l=2,llm-1
    805      DO ij=1,ip1jmp1
    806         IF(dzqw(ij,l)*dzqw(ij,l+1)>0.) THEN
    807             dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
    808         ELSE
    809             dzq(ij,l)=0.
    810         ENDIF
    811         dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
    812         dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
    813      ENDDO
     793  DO l = 2, llm
     794    DO ij = 1, ip1jmp1
     795      dzqw(ij, l) = q(ij, l - 1, iq) - q(ij, l, iq)
     796      adzqw(ij, l) = abs(dzqw(ij, l))
     797    ENDDO
     798  ENDDO
     799
     800  DO l = 2, llm - 1
     801    DO ij = 1, ip1jmp1
     802      IF(dzqw(ij, l) * dzqw(ij, l + 1)>0.) THEN
     803        dzq(ij, l) = 0.5 * (dzqw(ij, l) + dzqw(ij, l + 1))
     804      ELSE
     805        dzq(ij, l) = 0.
     806      ENDIF
     807      dzqmax = pente_max * min(adzqw(ij, l), adzqw(ij, l + 1))
     808      dzq(ij, l) = sign(min(abs(dzq(ij, l)), dzqmax), dzq(ij, l))
     809    ENDDO
    814810  ENDDO
    815811
    816812  ! !WRITE(*,*) 'vlz 954'
    817   DO ij=1,ip1jmp1
    818      dzq(ij,1)=0.
    819      dzq(ij,llm)=0.
     813  DO ij = 1, ip1jmp1
     814    dzq(ij, 1) = 0.
     815    dzq(ij, llm) = 0.
    820816  ENDDO
    821817
    … …  
    826822  ! calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
    827823
    828    DO l = 1,llm-1
    829      do  ij = 1,ip1jmp1
    830       IF(w(ij,l+1)>0.) THEN
    831          sigw=w(ij,l+1)/masse(ij,l+1,iq)
    832          wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1,iq) &
    833                +0.5*(1.-sigw)*dzq(ij,l+1))
     824  DO l = 1, llm - 1
     825    do  ij = 1, ip1jmp1
     826      IF(w(ij, l + 1)>0.) THEN
     827        sigw = w(ij, l + 1) / masse(ij, l + 1, iq)
     828        wq(ij, l + 1) = w(ij, l + 1) * (q(ij, l + 1, iq) &
     829                + 0.5 * (1. - sigw) * dzq(ij, l + 1))
    834830      ELSE
    835          sigw=w(ij,l+1)/masse(ij,l,iq)
    836          wq(ij,l+1)=w(ij,l+1)*(q(ij,l,iq)-0.5*(1.+sigw)*dzq(ij,l))
     831        sigw = w(ij, l + 1) / masse(ij, l, iq)
     832        wq(ij, l + 1) = w(ij, l + 1) * (q(ij, l, iq) - 0.5 * (1. + sigw) * dzq(ij, l))
    837833      ENDIF
    838      ENDDO
    839    ENDDO
    840 
    841    DO ij=1,ip1jmp1
    842       wq(ij,llm+1)=0.
    843       wq(ij,1)=0.
    844    ENDDO
     834    ENDDO
     835  ENDDO
     836
     837  DO ij = 1, ip1jmp1
     838    wq(ij, llm + 1) = 0.
     839    wq(ij, 1) = 0.
     840  ENDDO
    845841
    846842  ! CRisi: appel récursif de l'advection sur les fils.
    847843  ! Il faut faire ça avant d'avoir mis à jour q et masse
    848844  ! !WRITE(*,*) 'vlsplt 942: iq,nqChildren(iq)=',iq,nqChildren(iq)
    849   do ifils=1,tracers(iq)%nqDescen
    850     iq2=tracers(iq)%iqDescen(ifils)
    851     DO l=1,llm
    852       DO ij=1,ip1jmp1
     845  do ifils = 1, tracers(iq)%nqDescen
     846    iq2 = tracers(iq)%iqDescen(ifils)
     847    DO l = 1, llm
     848      DO ij = 1, ip1jmp1
    853849        ! !masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
    854   !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     850        !           !Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
    855851        ! !MVals: veiller a ce qu'on n'ait pas de denominateur nul
    856         masseq(ij,l,iq2)=max(masse(ij,l,iq)*q(ij,l,iq),min_qMass)
    857         IF (q(ij,l,iq)>min_qParent) THEN
    858           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     852        masseq(ij, l, iq2) = max(masse(ij, l, iq) * q(ij, l, iq), min_qMass)
     853        IF (q(ij, l, iq)>min_qParent) THEN
     854          Ratio(ij, l, iq2) = q(ij, l, iq2) / q(ij, l, iq)
    859855        else
    860           Ratio(ij,l,iq2)=min_ratio
     856          Ratio(ij, l, iq2) = min_ratio
    861857        endif
    862858      enddo
    … …  
    864860  enddo
    865861
    866   do ifils=1,tracers(iq)%nqChildren
    867     iq2=tracers(iq)%iqDescen(ifils)
    868     CALL vlz(Ratio,pente_max,masseq,wq,iq2)
     862  do ifils = 1, tracers(iq)%nqChildren
     863    iq2 = tracers(iq)%iqDescen(ifils)
     864    CALL vlz(Ratio, pente_max, masseq, wq, iq2)
    869865  enddo
    870866  ! end CRisi
    871867
    872   DO l=1,llm
    873      DO ij=1,ip1jmp1
    874         newmasse=masse(ij,l,iq)+w(ij,l+1)-w(ij,l)
    875         q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+wq(ij,l+1)-wq(ij,l)) &
    876               /newmasse
    877         masse(ij,l,iq)=newmasse
    878      ENDDO
     868  DO l = 1, llm
     869    DO ij = 1, ip1jmp1
     870      newmasse = masse(ij, l, iq) + w(ij, l + 1) - w(ij, l)
     871      q(ij, l, iq) = (q(ij, l, iq) * masse(ij, l, iq) + wq(ij, l + 1) - wq(ij, l)) &
     872              / newmasse
     873      masse(ij, l, iq) = newmasse
     874    ENDDO
    879875  ENDDO
    880876
    881877  ! retablir les fils en rapport de melange par rapport a l'air:
    882   do ifils=1,tracers(iq)%nqDescen
    883     iq2=tracers(iq)%iqDescen(ifils)
    884     DO l=1,llm
    885       DO ij=1,ip1jmp1
    886         q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
     878  do ifils = 1, tracers(iq)%nqDescen
     879    iq2 = tracers(iq)%iqDescen(ifils)
     880    DO l = 1, llm
     881      DO ij = 1, ip1jmp1
     882        q(ij, l, iq2) = q(ij, l, iq) * Ratio(ij, l, iq2)
    887883      enddo
    888884    enddo
    889885  enddo
    890886
    891 
    892887END SUBROUTINE vlz
    893888
    894 SUBROUTINE minmaxq(zq,qmin,qmax,comment)
     889SUBROUTINE minmaxq(zq, qmin, qmax, comment)
    895890
    896891  INCLUDE "dimensions.h"
    897892  INCLUDE "paramet.h"
    898893
    899   CHARACTER(LEN=20) :: comment
    900   REAL :: qmin,qmax
    901   REAL :: zq(ip1jmp1,llm)
    902   REAL :: zzq(iip1,jjp1,llm)
     894  CHARACTER(LEN = 20) :: comment
     895  REAL :: qmin, qmax
     896  REAL :: zq(ip1jmp1, llm)
     897  REAL :: zzq(iip1, jjp1, llm)
    903898
    904899END SUBROUTINE  minmaxq

  • LMDZ6/branches/Amaury_dev/libf/dyn3d/vlspltqs.F90

    r5117 r5119  
    2626  USE comconst_mod, ONLY: cpp
    2727  USE logic_mod, ONLY: adv_qsat_liq
     28  USE lmdz_ssum_scopy, ONLY: scopy
    2829  IMPLICIT NONE
    2930  !
    … …  
    172173  enddo
    173174  !WRITE(*,*) 'vlspltqs 183: fin de la routine'
    174 
    175175
    176176END SUBROUTINE vlspltqs
    … …  
    505505  ! CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
    506506  ! CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
    507 
    508507
    509508END SUBROUTINE vlxqs
    … …  
    840839  ! !WRITE(*,*) 'vly 879'
    841840
    842 
    843841END SUBROUTINE vlyqs

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/com_io_dyn_mod.F90

    r5116 r5119  
    2929  INTEGER :: histuaveid
    3030 
    31 end module com_io_dyn_mod
     31END MODULE com_io_dyn_mod

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad.f90

    r5106 r5119  
    1 
    21! $Header$
    32
    4 SUBROUTINE divgrad(klevel,h, lh, divgra )
     3SUBROUTINE divgrad(klevel, h, lh, divgra)
    54  USE lmdz_filtreg, ONLY: filtreg
     5  USE lmdz_ssum_scopy, ONLY: scopy
    66  IMPLICIT NONE
    77  !
    … …  
    2727  !
    2828  INTEGER :: klevel
    29   REAL :: h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
     29  REAL :: h(ip1jmp1, klevel), divgra(ip1jmp1, klevel)
    3030  !
    31   REAL :: ghy(ip1jm,llm), ghx(ip1jmp1,llm)
     31  REAL :: ghy(ip1jm, llm), ghx(ip1jmp1, llm)
    3232
    33   INTEGER :: l,ij,iter,lh
     33  INTEGER :: l, ij, iter, lh
    3434  !
    3535  !
    3636  !
    37   CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 )
     37  CALL SCOPY (ip1jmp1 * klevel, h, 1, divgra, 1)
    3838  !
    39   DO iter = 1,lh
     39  DO iter = 1, lh
    4040
    41   CALL filtreg ( divgra,jjp1,klevel,2,1,.TRUE.,1  )
     41    CALL filtreg (divgra, jjp1, klevel, 2, 1, .TRUE., 1)
    4242
    43   CALL    grad (klevel,divgra, ghx  , ghy          )
    44   CALL  diverg (klevel,  ghx , ghy  , divgra       )
     43    CALL    grad (klevel, divgra, ghx, ghy)
     44    CALL  diverg (klevel, ghx, ghy, divgra)
    4545
    46   CALL filtreg ( divgra,jjp1,klevel,2,1,.TRUE.,1)
     46    CALL filtreg (divgra, jjp1, klevel, 2, 1, .TRUE., 1)
    4747
    48   DO l = 1,klevel
    49   DO ij = 1, ip1jmp1
    50   divgra( ij,l ) = - cdivh * divgra( ij,l )
    51   END DO
    52   END DO
    53   !
     48    DO l = 1, klevel
     49      DO ij = 1, ip1jmp1
     50        divgra(ij, l) = - cdivh * divgra(ij, l)
     51      END DO
     52    END DO
     53    !
    5454  END DO
    5555  RETURN

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/divgrad2.f90

    r5106 r5119  
    1 
    21! $Header$
    32
    4 SUBROUTINE divgrad2( klevel, h, deltapres, lh, divgra )
     3SUBROUTINE divgrad2(klevel, h, deltapres, lh, divgra)
    54  !
    65  ! P. Le Van
    … …  
    1312  !     divgra     est  un argument  de sortie pour le s-prg
    1413  !
     14  USE lmdz_ssum_scopy, ONLY: scopy
     15
    1516  IMPLICIT NONE
    1617  !
    … …  
    2324  !
    2425  INTEGER :: klevel
    25   REAL :: h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel )
    26   REAL :: divgra( ip1jmp1,klevel)
     26  REAL :: h(ip1jmp1, klevel), deltapres(ip1jmp1, klevel)
     27  REAL :: divgra(ip1jmp1, klevel)
    2728  !
    2829  !    .......    variables  locales    ..........
    2930  !
    30   REAL :: signe, nudivgrs, sqrtps( ip1jmp1,llm )
    31   INTEGER :: l,ij,iter,lh
     31  REAL :: signe, nudivgrs, sqrtps(ip1jmp1, llm)
     32  INTEGER :: l, ij, iter, lh
    3233  !    ...................................................................
    3334
    3435  !
    35   signe    = (-1.)**lh
     36  signe = (-1.)**lh
    3637  nudivgrs = signe * cdivh
    3738
    38   CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
     39  CALL SCOPY (ip1jmp1 * klevel, h, 1, divgra, 1)
    3940
    4041  !
    41   CALL laplacien( klevel, divgra, divgra )
     42  CALL laplacien(klevel, divgra, divgra)
    4243
    4344  DO l = 1, klevel
    44    DO ij = 1, ip1jmp1
    45     sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
    46    ENDDO
     45    DO ij = 1, ip1jmp1
     46      sqrtps(ij, l) = SQRT(deltapres(ij, l))
     47    ENDDO
    4748  ENDDO
    4849  !
    4950  DO l = 1, klevel
    5051    DO ij = 1, ip1jmp1
    51      divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
     52      divgra(ij, l) = divgra(ij, l) * sqrtps(ij, l)
    5253    ENDDO
    5354  ENDDO
    … …  
    5657  !
    5758  DO  iter = 1, lh - 2
    58    CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2, &
    59          unsapolnga2, unsapolsga2,  divgra, divgra )
     59    CALL laplacien_gam (klevel, cuvscvgam2, cvuscugam2, unsair_gam2, &
     60            unsapolnga2, unsapolsga2, divgra, divgra)
    6061  ENDDO
    6162  !
    … …  
    6465  DO l = 1, klevel
    6566    DO ij = 1, ip1jmp1
    66       divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
     67      divgra(ij, l) = divgra(ij, l) * sqrtps(ij, l)
    6768    ENDDO
    6869  ENDDO
    6970  !
    70   CALL laplacien ( klevel, divgra, divgra )
     71  CALL laplacien (klevel, divgra, divgra)
    7172  !
    72   DO l  = 1,klevel
    73   DO ij = 1,ip1jmp1
    74   divgra(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
    75   ENDDO
     73  DO l = 1, klevel
     74    DO ij = 1, ip1jmp1
     75      divgra(ij, l) = nudivgrs * divgra(ij, l) / deltapres(ij, l)
     76    ENDDO
    7677  ENDDO
    7778

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/exner_hyb_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  SUBROUTINE exner_hyb( ngrid, ps, p, pks, pk, pkf )
    … …  
    145145  END SUBROUTINE exner_hyb
    146146
    147 end module exner_hyb_m
     147END MODULE exner_hyb_m

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/exner_milieu_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  SUBROUTINE exner_milieu( ngrid, ps, p, pks, pk, pkf )
    … …  
    124124  END SUBROUTINE exner_milieu
    125125
    126 end module exner_milieu_m
     126END MODULE exner_milieu_m

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fxhyp_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  SUBROUTINE fxhyp(xprimm025, rlonv, xprimv, rlonu, xprimu, xprimp025)
    … …  
    246246  END SUBROUTINE fxhyp
    247247
    248 end module fxhyp_m
     248END MODULE fxhyp_m

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/fyhyp_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  SUBROUTINE fyhyp(rlatu, yyprimu, rlatv, rlatu2, yprimu2, rlatu1, yprimu1)
    … …  
    338338  END SUBROUTINE fyhyp
    339339
    340 end module fyhyp_m
     340END MODULE fyhyp_m

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gr_u_scal.f90

    r5105 r5119  
    1 
    21! $Header$
    32
    4 SUBROUTINE gr_u_scal(nx,x_u,x_scal)
     3SUBROUTINE gr_u_scal(nx, x_u, x_scal)
    54  !%W%    %G%
    65  !=======================================================================
    … …  
    2524  !
    2625  !=======================================================================
     26  USE lmdz_ssum_scopy, ONLY: scopy
     27
    2728  IMPLICIT NONE
    2829  !-----------------------------------------------------------------------
    … …  
    3839
    3940  INTEGER :: nx
    40   REAL :: x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx)
     41  REAL :: x_u(ip1jmp1, nx), x_scal(ip1jmp1, nx)
    4142
    4243  !   Local:
    4344  !   ------
    4445
    45   INTEGER :: l,ij
     46  INTEGER :: l, ij
    4647
    4748  !-----------------------------------------------------------------------
    4849
    49   DO l=1,nx
    50      DO ij=ip1jmp1,2,-1
    51         x_scal(ij,l)= &
    52               (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) &
    53               /(aireu(ij)+aireu(ij-1))
    54      ENDDO
     50  DO l = 1, nx
     51    DO ij = ip1jmp1, 2, -1
     52      x_scal(ij, l) = &
     53              (aireu(ij) * x_u(ij, l) + aireu(ij - 1) * x_u(ij - 1, l)) &
     54                      / (aireu(ij) + aireu(ij - 1))
     55    ENDDO
    5556  ENDDO
    5657
    57   CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1)
     58  CALL SCOPY(nx * jjp1, x_scal(iip1, 1), iip1, x_scal(1, 1), iip1)
    5859
    5960  RETURN

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv.f90

    r5106 r5119  
    1 
    21! $Header$
    32
    4 SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy )
     3SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy)
    54  !
    65  !    Auteur :   P. Le Van
    … …  
    1817  !
    1918  USE lmdz_filtreg, ONLY: filtreg
     19  USE lmdz_ssum_scopy, ONLY: scopy
     20
    2021  IMPLICIT NONE
    2122  !
    … …  
    2627  INTEGER :: klevel
    2728  !
    28   REAL :: xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
    29   REAL :: gdx( ip1jmp1,klevel ),   gdy( ip1jm,klevel )
     29  REAL :: xcov(ip1jmp1, klevel), ycov(ip1jm, klevel)
     30  REAL :: gdx(ip1jmp1, klevel), gdy(ip1jm, klevel)
    3031
    31   REAL :: div(ip1jmp1,llm)
     32  REAL :: div(ip1jmp1, llm)
    3233
    33   INTEGER :: l,ij,iter,ld
     34  INTEGER :: l, ij, iter, ld
    3435  !
    3536  !
    3637  !
    37   CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 )
    38   CALL SCOPY( ip1jm*klevel,  ycov,1,gdy,1 )
     38  CALL SCOPY(ip1jmp1 * klevel, xcov, 1, gdx, 1)
     39  CALL SCOPY(ip1jm * klevel, ycov, 1, gdy, 1)
    3940  !
    40   DO iter = 1,ld
    41   !
    42   CALL  diverg( klevel,  gdx , gdy, div          )
    43   CALL filtreg( div, jjp1, klevel, 2,1, .TRUE.,2 )
    44   CALL    grad( klevel,  div, gdx, gdy           )
    45   !
    46   DO l = 1, klevel
    47   DO ij = 1, ip1jmp1
    48   gdx( ij,l ) = - gdx( ij,l ) * cdivu
    49   END DO
    50   DO ij = 1, ip1jm
    51   gdy( ij,l ) = - gdy( ij,l ) * cdivu
    52   END DO
    53   END DO
    54   !
     41  DO iter = 1, ld
     42    !
     43    CALL  diverg(klevel, gdx, gdy, div)
     44    CALL filtreg(div, jjp1, klevel, 2, 1, .TRUE., 2)
     45    CALL    grad(klevel, div, gdx, gdy)
     46    !
     47    DO l = 1, klevel
     48      DO ij = 1, ip1jmp1
     49        gdx(ij, l) = - gdx(ij, l) * cdivu
     50      END DO
     51      DO ij = 1, ip1jm
     52        gdy(ij, l) = - gdy(ij, l) * cdivu
     53      END DO
     54    END DO
     55    !
    5556  END DO
    5657  RETURN

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/gradiv2.f90

    r5106 r5119  
    1 
    21! $Header$
    32
    4 SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy )
     3SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy)
    54  !
    65  ! P. Le Van
    … …  
    1716  !
    1817  USE lmdz_filtreg, ONLY: filtreg
     18  USE lmdz_ssum_scopy, ONLY: scopy
     19
    1920  IMPLICIT NONE
    2021  !
    … …  
    2728
    2829  INTEGER :: klevel
    29   REAL :: xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
    30   REAL :: gdx( ip1jmp1,klevel ),  gdy( ip1jm,klevel )
     30  REAL :: xcov(ip1jmp1, klevel), ycov(ip1jm, klevel)
     31  REAL :: gdx(ip1jmp1, klevel), gdy(ip1jm, klevel)
    3132  !
    3233  ! ........       variables locales       .........
    3334  !
    34   REAL :: div(ip1jmp1,llm)
     35  REAL :: div(ip1jmp1, llm)
    3536  REAL :: signe, nugrads
    36   INTEGER :: l,ij,iter,ld
     37  INTEGER :: l, ij, iter, ld
    3738
    3839  !    ........................................................
    3940  !
    4041  !
    41   CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
    42   CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
     42  CALL SCOPY(ip1jmp1 * klevel, xcov, 1, gdx, 1)
     43  CALL SCOPY(ip1jm * klevel, ycov, 1, gdy, 1)
    4344  !
    4445  !
    45   signe   = (-1.)**ld
     46  signe = (-1.)**ld
    4647  nugrads = signe * cdivu
    4748  !
    4849
     50  CALL    divergf(klevel, gdx, gdy, div)
    4951
    50   CALL    divergf( klevel, gdx,   gdy , div )
     52  IF(ld>1)   THEN
    5153
    52   IF( ld>1 )   THEN
     54    CALL laplacien (klevel, div, div)
    5355
    54     CALL laplacien ( klevel, div,  div     )
     56    !    ......  Iteration de l'operateur laplacien_gam   .......
    5557
    56   !    ......  Iteration de l'operateur laplacien_gam   .......
    57 
    58     DO iter = 1, ld -2
    59      CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1, &
    60            unsapolnga1, unsapolsga1,  div, div       )
     58    DO iter = 1, ld - 2
     59      CALL laplacien_gam (klevel, cuvscvgam1, cvuscugam1, unsair_gam1, &
     60              unsapolnga1, unsapolsga1, div, div)
    6161    ENDDO
    6262
    6363  ENDIF
    6464
    65 
    66    CALL filtreg( div   , jjp1, klevel, 2, 1, .TRUE., 1 )
    67    CALL  grad  ( klevel,  div,   gdx,  gdy             )
     65  CALL filtreg(div, jjp1, klevel, 2, 1, .TRUE., 1)
     66  CALL  grad  (klevel, div, gdx, gdy)
    6867
    6968  !
    70    DO   l = 1, klevel
    71      DO  ij = 1, ip1jmp1
    72       gdx( ij,l ) = gdx( ij,l ) * nugrads
    73      ENDDO
    74      DO  ij = 1, ip1jm
    75       gdy( ij,l ) = gdy( ij,l ) * nugrads
    76      ENDDO
    77    ENDDO
     69  DO   l = 1, klevel
     70    DO  ij = 1, ip1jmp1
     71      gdx(ij, l) = gdx(ij, l) * nugrads
     72    ENDDO
     73    DO  ij = 1, ip1jm
     74      gdy(ij, l) = gdy(ij, l) * nugrads
     75    ENDDO
     76  ENDDO
    7877  !
    79    RETURN
     78  RETURN
    8079END SUBROUTINE gradiv2

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/inter_barxy_m.F90

    r5117 r5119  
    1010  public inter_barxy
    1111
    12 contains
     12CONTAINS
    1313
    1414  SUBROUTINE inter_barxy(dlonid, dlatid, champ, rlonimod, rlatimod, champint)
    … …  
    448448  END function ord_coordm
    449449
    450 end module inter_barxy_m
     450END MODULE inter_barxy_m

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/invert_zoom_x_m.F90

    r5117 r5119  
    55  INTEGER, PARAMETER:: nmax = 30000
    66
    7 contains
     7CONTAINS
    88
    99  SUBROUTINE invert_zoom_x(xf, xtild, Xprimt, xlon, xprimm, xuv)
    … …  
    8686  END SUBROUTINE  invert_zoom_x
    8787
    88 end module invert_zoom_x_m
     88END MODULE invert_zoom_x_m

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien.f90

    r5106 r5119  
    1 
    21! $Header$
    32
    4 SUBROUTINE laplacien( klevel, teta, divgra )
     3SUBROUTINE laplacien(klevel, teta, divgra)
    54  !
    65  ! P. Le Van
    … …  
    1312  !
    1413  USE lmdz_filtreg, ONLY: filtreg
     14  USE lmdz_ssum_scopy, ONLY: scopy
     15
    1516  IMPLICIT NONE
    1617  !
    … …  
    2324  !
    2425  INTEGER :: klevel
    25   REAL :: teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
     26  REAL :: teta(ip1jmp1, klevel), divgra(ip1jmp1, klevel)
    2627  !
    2728  !    ............     variables  locales      ..............
    2829  !
    29   REAL :: ghy(ip1jm,llm), ghx(ip1jmp1,llm)
     30  REAL :: ghy(ip1jm, llm), ghx(ip1jmp1, llm)
    3031  !    .......................................................
    3132
    3233
    3334  !
    34   CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
     35  CALL SCOPY (ip1jmp1 * klevel, teta, 1, divgra, 1)
    3536
    36   CALL filtreg( divgra,  jjp1, klevel,  2, 1, .TRUE., 1 )
    37   CALL   grad ( klevel,divgra,   ghx , ghy              )
    38   CALL  divergf ( klevel, ghx , ghy  , divgra           )
     37  CALL filtreg(divgra, jjp1, klevel, 2, 1, .TRUE., 1)
     38  CALL   grad (klevel, divgra, ghx, ghy)
     39  CALL  divergf (klevel, ghx, ghy, divgra)
    3940
    4041  RETURN

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/laplacien_gam.f90

    r5106 r5119  
    1 
    21! $Header$
    32
    4 SUBROUTINE laplacien_gam( klevel, cuvsga, cvusga, unsaigam , &
    5         unsapolnga, unsapolsga, teta, divgra )
     3SUBROUTINE laplacien_gam(klevel, cuvsga, cvusga, unsaigam, &
     4        unsapolnga, unsapolsga, teta, divgra)
    65
    76  !  P. Le Van
    … …  
    1413  !  divgra     est  un argument  de sortie pour le s-prog
    1514  !
     15  USE lmdz_ssum_scopy, ONLY: scopy
     16
    1617  IMPLICIT NONE
    1718  !
    … …  
    2425  !
    2526  INTEGER :: klevel
    26   REAL :: teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
    27   REAL :: cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1), &
    28         unsapolnga, unsapolsga
     27  REAL :: teta(ip1jmp1, klevel), divgra(ip1jmp1, klevel)
     28  REAL :: cuvsga(ip1jm), cvusga(ip1jmp1), unsaigam(ip1jmp1), &
     29          unsapolnga, unsapolsga
    2930  !
    3031  !    ...........    variables  locales    .................
    3132  !
    32   REAL :: ghy(ip1jm,llm), ghx(ip1jmp1,llm)
     33  REAL :: ghy(ip1jm, llm), ghx(ip1jmp1, llm)
    3334  !    ......................................................
    3435
    … …  
    4041  !
    4142
    42   CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
     43  CALL SCOPY (ip1jmp1 * klevel, teta, 1, divgra, 1)
    4344  !
    44   CALL   grad ( klevel, divgra, ghx, ghy )
     45  CALL   grad (klevel, divgra, ghx, ghy)
    4546  !
    46   CALL  diverg_gam ( klevel, cuvsga, cvusga,  unsaigam  , &
    47         unsapolnga, unsapolsga, ghx , ghy , divgra )
     47  CALL  diverg_gam (klevel, cuvsga, cvusga, unsaigam, &
     48          unsapolnga, unsapolsga, ghx, ghy, divgra)
    4849
    4950  !
    5051
    51 
    5252  RETURN
    5353END SUBROUTINE laplacien_gam

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/misc_mod.F90

    r5117 r5119  
    44  INTEGER,save :: ItCount
    55  logical,save :: debug
    6 end module misc_mod
     6END MODULE misc_mod

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgraro2.f90

    r5106 r5119  
    1 
    21! $Header$
    32
    4  SUBROUTINE nxgraro2(klevel,xcov, ycov, lr, grx, gry )
     3SUBROUTINE nxgraro2(klevel, xcov, ycov, lr, grx, gry)
    54  !
    65  !  P.Le Van .
    … …  
    1615  !
    1716  USE lmdz_filtreg, ONLY: filtreg
     17  USE lmdz_ssum_scopy, ONLY: scopy
     18
    1819  IMPLICIT NONE
    1920  !
    … …  
    2526  !
    2627  INTEGER :: klevel
    27   REAL :: xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
    28   REAL :: grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
     28  REAL :: xcov(ip1jmp1, klevel), ycov(ip1jm, klevel)
     29  REAL :: grx(ip1jmp1, klevel), gry(ip1jm, klevel)
    2930  !
    3031  !    ......   variables locales     ........
    3132  !
    32   REAL :: rot(ip1jm,llm) , signe, nugradrs
    33   INTEGER :: l,ij,iter,lr
     33  REAL :: rot(ip1jm, llm), signe, nugradrs
     34  INTEGER :: l, ij, iter, lr
    3435  !    ........................................................
    3536  !
    3637  !
    3738  !
    38   signe    = (-1.)**lr
     39  signe = (-1.)**lr
    3940  nugradrs = signe * crot
    4041  !
    41   CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
    42   CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
     42  CALL SCOPY (ip1jmp1 * klevel, xcov, 1, grx, 1)
     43  CALL SCOPY (ip1jm * klevel, ycov, 1, gry, 1)
    4344  !
    44   CALL     rotatf     ( klevel, grx, gry, rot )
     45  CALL     rotatf     (klevel, grx, gry, rot)
    4546  !
    46   CALL laplacien_rot ( klevel, rot, rot,grx,gry      )
     47  CALL laplacien_rot (klevel, rot, rot, grx, gry)
    4748
    4849  !
    4950  !    .....   Iteration de l'operateur laplacien_rotgam  .....
    5051  !
    51   DO  iter = 1, lr -2
    52     CALL laplacien_rotgam ( klevel, rot, rot )
     52  DO  iter = 1, lr - 2
     53    CALL laplacien_rotgam (klevel, rot, rot)
    5354  ENDDO
    5455  !
    5556  !
    56   CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1)
    57   CALL nxgrad ( klevel, rot, grx, gry )
     57  CALL filtreg(rot, jjm, klevel, 2, 1, .FALSE., 1)
     58  CALL nxgrad (klevel, rot, grx, gry)
    5859  !
    5960  DO    l = 1, klevel
    60      DO  ij = 1, ip1jm
    61       gry( ij,l ) = gry( ij,l ) * nugradrs
    62      ENDDO
    63      DO  ij = 1, ip1jmp1
    64       grx( ij,l ) = grx( ij,l ) * nugradrs
    65      ENDDO
     61    DO  ij = 1, ip1jm
     62      gry(ij, l) = gry(ij, l) * nugradrs
     63    ENDDO
     64    DO  ij = 1, ip1jmp1
     65      grx(ij, l) = grx(ij, l) * nugradrs
     66    ENDDO
    6667  ENDDO
    6768  !

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/nxgrarot.f90

    r5106 r5119  
    1 
    21! $Header$
    32
    4 SUBROUTINE nxgrarot(klevel,xcov, ycov, lr, grx, gry )
     3SUBROUTINE nxgrarot(klevel, xcov, ycov, lr, grx, gry)
    54  !   ***********************************************************
    65  !
    … …  
    1716  !
    1817  USE lmdz_filtreg, ONLY: filtreg
     18  USE lmdz_ssum_scopy, ONLY: scopy
     19
    1920  IMPLICIT NONE
    2021  !
    … …  
    2526  !
    2627  INTEGER :: klevel
    27   REAL :: xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
    28   REAL :: grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
     28  REAL :: xcov(ip1jmp1, klevel), ycov(ip1jm, klevel)
     29  REAL :: grx(ip1jmp1, klevel), gry(ip1jm, klevel)
    2930  !
    30   REAL :: rot(ip1jm,llm)
     31  REAL :: rot(ip1jm, llm)
    3132
    32   INTEGER :: l,ij,iter,lr
     33  INTEGER :: l, ij, iter, lr
    3334  !
    3435  !
    3536  !
    36   CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 )
    37   CALL SCOPY (  ip1jm*klevel, ycov, 1, gry, 1 )
     37  CALL SCOPY (ip1jmp1 * klevel, xcov, 1, grx, 1)
     38  CALL SCOPY (ip1jm * klevel, ycov, 1, gry, 1)
    3839  !
    39   DO iter = 1,lr
    40   CALL  rotat (klevel,grx, gry, rot )
    41   CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,2)
    42   CALL nxgrad (klevel,rot, grx, gry )
    43   !
    44   DO l = 1, klevel
    45   DO ij = 1, ip1jm
    46   gry( ij,l ) = - gry( ij,l ) * crot
    47   END DO
    48   DO ij = 1, ip1jmp1
    49   grx( ij,l ) = - grx( ij,l ) * crot
    50   END DO
    51   END DO
    52   !
     40  DO iter = 1, lr
     41    CALL  rotat (klevel, grx, gry, rot)
     42    CALL filtreg(rot, jjm, klevel, 2, 1, .FALSE., 2)
     43    CALL nxgrad (klevel, rot, grx, gry)
     44    !
     45    DO l = 1, klevel
     46      DO ij = 1, ip1jm
     47        gry(ij, l) = - gry(ij, l) * crot
     48      END DO
     49      DO ij = 1, ip1jmp1
     50        grx(ij, l) = - grx(ij, l) * crot
     51      END DO
     52    END DO
     53    !
    5354  END DO
    5455  RETURN

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/principal_cshift_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  SUBROUTINE principal_cshift(is2, xlon, xprimm)
    … …  
    4141  END SUBROUTINE  principal_cshift
    4242
    43 end module principal_cshift_m
     43END MODULE principal_cshift_m

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/sortvarc.f90

    r5118 r5119  
    1313  USE lmdz_filtreg, ONLY: filtreg
    1414  USE lmdz_iniprint, ONLY: lunout, prt_level
     15  USE lmdz_ssum_scopy, ONLY: scopy
     16
    1517  IMPLICIT NONE
    1618

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/bands.F90

    r5117 r5119  
    2424    INTEGER,DIMENSION(:),ALLOCATABLE :: distrib_phys
    2525 
    26   contains
     26  CONTAINS
    2727 
    2828  SUBROUTINE AllocateBands
    … …  
    483483    END SUBROUTINE  WriteBands
    484484 
    485   end module Bands
    486  
    487  
    488 
     485  END MODULE Bands
     486 
     487 
     488

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/exner_hyb_loc_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  SUBROUTINE  exner_hyb_loc(ngrid, ps, p, pks, pk, pkf)
    … …  
    196196  END SUBROUTINE exner_hyb_loc
    197197
    198 end module exner_hyb_loc_m
     198END MODULE exner_hyb_loc_m

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/exner_milieu_loc_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  SUBROUTINE exner_milieu_loc( ngrid, ps, p, pks, pk, pkf )
    … …  
    161161  END SUBROUTINE exner_milieu_loc
    162162
    163 end module exner_milieu_loc_m
     163END MODULE exner_milieu_loc_m

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/mod_hallo.F90

    r5117 r5119  
    6565  END INTERFACE Register_SwapField2d_v
    6666
    67   contains
     67  CONTAINS
    6868
    6969  SUBROUTINE Init_mod_hallo
    … …  
    18581858    END SUBROUTINE  Scatter_field_v
    18591859             
    1860 end module mod_Hallo
    1861    
     1860END MODULE mod_Hallo
     1861   

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/parallel_lmdz.F90

    r5118 r5119  
    7676  TYPE(distrib), SAVE :: current_dist
    7777
    78 contains
     78CONTAINS
    7979
    8080  SUBROUTINE init_parallel

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/times.F90

    r5117 r5119  
    2222  INTEGER, ALLOCATABLE,DIMENSION(:) :: timer_state
    2323 
    24   contains
     24  CONTAINS
    2525 
    2626  SUBROUTINE init_timer
    … …  
    228228  END FUNCTION DiffCpuTime
    229229
    230 end module times
     230END MODULE times

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/write_field_loc.F90

    r5117 r5119  
    1010  end interface WriteField_v
    1111 
    12   contains
     12  CONTAINS
    1313 
    1414  SUBROUTINE write_field1D_u(name,Field)
    … …  
    152152    END SUBROUTINE write_field_v_gen
    153153   
    154 end module write_field_loc
     154END MODULE write_field_loc
    155155 

  • LMDZ6/branches/Amaury_dev/libf/dyn3dmem/write_field_p.F90

    r5117 r5119  
    66  end interface WriteField_p
    77 
    8   contains
     8  CONTAINS
    99 
    1010  SUBROUTINE write_field1D_p(name,Field)
    … …  
    7070  END SUBROUTINE  write_field3D_p
    7171
    72 end module write_field_p
     72END MODULE write_field_p
    7373 

  • LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/calfis.f90

    r5118 r5119  
    1 
    21! $Id$
    32
    … …  
    3635  USE comvert_mod, ONLY: preff, presnivs
    3736  USE lmdz_iniprint, ONLY: lunout, prt_level
     37  USE lmdz_ssum_scopy, ONLY: scopy
    3838
    3939  IMPLICIT NONE
    … …  
    9595
    9696  INTEGER :: ngridmx
    97   PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
     97  PARAMETER(ngridmx = 2 + (jjm - 1) * iim - 1 / jjm)
    9898
    9999  include "comgeom2.h"
    … …  
    101101  !    Arguments :
    102102  !    -----------
    103   LOGICAL,INTENT(IN) :: lafin ! .TRUE. for the very last CALL to physics
    104   REAL,INTENT(IN):: jD_cur, jH_cur
    105   REAL,INTENT(IN) :: pvcov(iip1,jjm,llm) ! covariant meridional velocity
    106   REAL,INTENT(IN) :: pucov(iip1,jjp1,llm) ! covariant zonal velocity
    107   REAL,INTENT(IN) :: pteta(iip1,jjp1,llm) ! potential temperature
    108   REAL,INTENT(IN) :: pmasse(iip1,jjp1,llm) ! mass in each cell ! not used
    109   REAL,INTENT(IN) :: pq(iip1,jjp1,llm,nqtot) ! tracers
    110   REAL,INTENT(IN) :: pphis(iip1,jjp1) ! surface geopotential
    111   REAL,INTENT(IN) :: pphi(iip1,jjp1,llm) ! geopotential
    112 
    113   REAL,INTENT(IN) :: pdvcov(iip1,jjm,llm) ! dynamical tendency on vcov
    114   REAL,INTENT(IN) :: pducov(iip1,jjp1,llm) ! dynamical tendency on ucov
    115   REAL,INTENT(IN) :: pdteta(iip1,jjp1,llm) ! dynamical tendency on teta
     103  LOGICAL, INTENT(IN) :: lafin ! .TRUE. for the very last CALL to physics
     104  REAL, INTENT(IN) :: jD_cur, jH_cur
     105  REAL, INTENT(IN) :: pvcov(iip1, jjm, llm) ! covariant meridional velocity
     106  REAL, INTENT(IN) :: pucov(iip1, jjp1, llm) ! covariant zonal velocity
     107  REAL, INTENT(IN) :: pteta(iip1, jjp1, llm) ! potential temperature
     108  REAL, INTENT(IN) :: pmasse(iip1, jjp1, llm) ! mass in each cell ! not used
     109  REAL, INTENT(IN) :: pq(iip1, jjp1, llm, nqtot) ! tracers
     110  REAL, INTENT(IN) :: pphis(iip1, jjp1) ! surface geopotential
     111  REAL, INTENT(IN) :: pphi(iip1, jjp1, llm) ! geopotential
     112
     113  REAL, INTENT(IN) :: pdvcov(iip1, jjm, llm) ! dynamical tendency on vcov
     114  REAL, INTENT(IN) :: pducov(iip1, jjp1, llm) ! dynamical tendency on ucov
     115  REAL, INTENT(IN) :: pdteta(iip1, jjp1, llm) ! dynamical tendency on teta
    116116  ! NB: pdteta is used only to compute pcvgt which is in fact not used...
    117   REAL,INTENT(IN) :: pdq(iip1,jjp1,llm,nqtot) ! dynamical tendency on tracers
     117  REAL, INTENT(IN) :: pdq(iip1, jjp1, llm, nqtot) ! dynamical tendency on tracers
    118118  ! NB: pdq is only used to compute pcvgq which is in fact not used...
    119119
    120   REAL,INTENT(IN) :: pps(iip1,jjp1) ! surface pressure (Pa)
    121   REAL,INTENT(IN) :: pp(iip1,jjp1,llmp1) ! pressure at mesh interfaces (Pa)
    122   REAL,INTENT(IN) :: ppk(iip1,jjp1,llm) ! Exner at mid-layer
    123   REAL,INTENT(IN) :: flxw(iip1,jjp1,llm) ! Vertical mass flux on lower mesh interfaces (kg/s) (on llm because flxw(:,:,llm+1)=0)
     120  REAL, INTENT(IN) :: pps(iip1, jjp1) ! surface pressure (Pa)
     121  REAL, INTENT(IN) :: pp(iip1, jjp1, llmp1) ! pressure at mesh interfaces (Pa)
     122  REAL, INTENT(IN) :: ppk(iip1, jjp1, llm) ! Exner at mid-layer
     123  REAL, INTENT(IN) :: flxw(iip1, jjp1, llm) ! Vertical mass flux on lower mesh interfaces (kg/s) (on llm because flxw(:,:,llm+1)=0)
    124124
    125125  ! tendencies (in */s) from the physics
    126   REAL,INTENT(OUT) :: pdvfi(iip1,jjm,llm) ! tendency on covariant meridional wind
    127   REAL,INTENT(OUT) :: pdufi(iip1,jjp1,llm) ! tendency on covariant zonal wind
    128   REAL,INTENT(OUT) :: pdhfi(iip1,jjp1,llm) ! tendency on potential temperature (K/s)
    129   REAL,INTENT(OUT) :: pdqfi(iip1,jjp1,llm,nqtot) ! tendency on tracers
    130   REAL,INTENT(OUT) :: pdpsfi(iip1,jjp1) ! tendency on surface pressure (Pa/s)
     126  REAL, INTENT(OUT) :: pdvfi(iip1, jjm, llm) ! tendency on covariant meridional wind
     127  REAL, INTENT(OUT) :: pdufi(iip1, jjp1, llm) ! tendency on covariant zonal wind
     128  REAL, INTENT(OUT) :: pdhfi(iip1, jjp1, llm) ! tendency on potential temperature (K/s)
     129  REAL, INTENT(OUT) :: pdqfi(iip1, jjp1, llm, nqtot) ! tendency on tracers
     130  REAL, INTENT(OUT) :: pdpsfi(iip1, jjp1) ! tendency on surface pressure (Pa/s)
    131131
    132132
    … …  
    134134  !    -----------------
    135135
    136   INTEGER :: i,j,l,ig0,ig,iq,itr
     136  INTEGER :: i, j, l, ig0, ig, iq, itr
    137137  REAL :: zpsrf(ngridmx)
    138   REAL :: zplev(ngridmx,llm+1),zplay(ngridmx,llm)
    139   REAL :: zphi(ngridmx,llm),zphis(ngridmx)
    140   !
    141   REAL :: zrot(iip1,jjm,llm) ! AdlC May 2014
    142   REAL :: zufi(ngridmx,llm), zvfi(ngridmx,llm)
    143   REAL :: zrfi(ngridmx,llm) ! relative wind vorticity
    144   REAL :: ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot)
    145   REAL :: zpk(ngridmx,llm)
    146   !
    147   REAL :: pcvgu(ngridmx,llm), pcvgv(ngridmx,llm)
    148   REAL :: pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2)
    149   !
    150   REAL :: zdufi(ngridmx,llm),zdvfi(ngridmx,llm)
    151   REAL :: zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot)
     138  REAL :: zplev(ngridmx, llm + 1), zplay(ngridmx, llm)
     139  REAL :: zphi(ngridmx, llm), zphis(ngridmx)
     140  !
     141  REAL :: zrot(iip1, jjm, llm) ! AdlC May 2014
     142  REAL :: zufi(ngridmx, llm), zvfi(ngridmx, llm)
     143  REAL :: zrfi(ngridmx, llm) ! relative wind vorticity
     144  REAL :: ztfi(ngridmx, llm), zqfi(ngridmx, llm, nqtot)
     145  REAL :: zpk(ngridmx, llm)
     146  !
     147  REAL :: pcvgu(ngridmx, llm), pcvgv(ngridmx, llm)
     148  REAL :: pcvgt(ngridmx, llm), pcvgq(ngridmx, llm, 2)
     149  !
     150  REAL :: zdufi(ngridmx, llm), zdvfi(ngridmx, llm)
     151  REAL :: zdtfi(ngridmx, llm), zdqfi(ngridmx, llm, nqtot)
    152152  REAL :: zdpsrf(ngridmx)
    153153  !
    154   REAL :: zdufic(ngridmx,llm),zdvfic(ngridmx,llm)
    155   REAL :: zdtfic(ngridmx,llm),zdqfic(ngridmx,llm,nqtot)
    156   REAL :: jH_cur_split,zdt_split
    157   LOGICAL :: debut_split,lafin_split
     154  REAL :: zdufic(ngridmx, llm), zdvfic(ngridmx, llm)
     155  REAL :: zdtfic(ngridmx, llm), zdqfic(ngridmx, llm, nqtot)
     156  REAL :: jH_cur_split, zdt_split
     157  LOGICAL :: debut_split, lafin_split
    158158  INTEGER :: isplit
    159159
    160   REAL :: zsin(iim),zcos(iim),z1(iim)
    161   REAL :: zsinbis(iim),zcosbis(iim),z1bis(iim)
     160  REAL :: zsin(iim), zcos(iim), z1(iim)
     161  REAL :: zsinbis(iim), zcosbis(iim), z1bis(iim)
    162162  REAL :: unskap, pksurcp
    163163  !
    164   REAL :: flxwfi(ngridmx,llm)  ! Flux de masse verticale sur la grille physiq
     164  REAL :: flxwfi(ngridmx, llm)  ! Flux de masse verticale sur la grille physiq
    165165  !
    166166
    167167  REAL :: SSUM
    168168
    169   LOGICAL,SAVE :: firstcal=.TRUE., debut=.TRUE.
    170    ! REAL rdayvrai
     169  LOGICAL, SAVE :: firstcal = .TRUE., debut = .TRUE.
     170  ! REAL rdayvrai
    171171
    172172  !
    … …  
    177177  !
    178178  !
    179   IF ( firstcal )  THEN
     179  IF (firstcal)  THEN
    180180    debut = .TRUE.
    181     IF (ngridmx/=2+(jjm-1)*iim) THEN
    182      WRITE(lunout,*) 'STOP dans calfis'
    183      WRITE(lunout,*) &
    184            'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
    185      WRITE(lunout,*) '  ngridmx  jjm   iim   '
    186      WRITE(lunout,*) ngridmx,jjm,iim
    187      CALL abort_gcm("calfis", "", 1)
     181    IF (ngridmx/=2 + (jjm - 1) * iim) THEN
     182      WRITE(lunout, *) 'STOP dans calfis'
     183      WRITE(lunout, *) &
     184              'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
     185      WRITE(lunout, *) '  ngridmx  jjm   iim   '
     186      WRITE(lunout, *) ngridmx, jjm, iim
     187      CALL abort_gcm("calfis", "", 1)
    188188    ENDIF
    189189  ELSE
    … …  
    200200  !   ----------------------------------
    201201
    202 
    203   zpsrf(1) = pps(1,1)
    204 
    205   ig0  = 2
    206   DO j = 2,jjm
    207      CALL SCOPY( iim,pps(1,j),1,zpsrf(ig0), 1 )
    208      ig0 = ig0+iim
    209   ENDDO
    210 
    211   zpsrf(ngridmx) = pps(1,jjp1)
     202  zpsrf(1) = pps(1, 1)
     203
     204  ig0 = 2
     205  DO j = 2, jjm
     206    CALL SCOPY(iim, pps(1, j), 1, zpsrf(ig0), 1)
     207    ig0 = ig0 + iim
     208  ENDDO
     209
     210  zpsrf(ngridmx) = pps(1, jjp1)
    212211
    213212
    … …  
    221220  !    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
    222221  !
    223    unskap   = 1./ kappa
    224   !
    225   DO l = 1, llm
    226     zpk(   1,l ) = ppk(1,1,l)
    227     zplev( 1,l ) = pp(1,1,l)
     222  unskap = 1. / kappa
     223  !
     224  DO l = 1, llm
     225    zpk(1, l) = ppk(1, 1, l)
     226    zplev(1, l) = pp(1, 1, l)
    228227    ig0 = 2
    229       DO j = 2, jjm
    230          DO i =1, iim
    231           zpk(   ig0,l ) = ppk(i,j,l)
    232           zplev( ig0,l ) = pp(i,j,l)
    233           ig0 = ig0 +1
    234          ENDDO
    235       ENDDO
    236     zpk(   ngridmx,l ) = ppk(1,jjp1,l)
    237     zplev( ngridmx,l ) = pp(1,jjp1,l)
    238   ENDDO
    239     zplev( 1,llmp1 ) = pp(1,1,llmp1)
    240     ig0 = 2
    241       DO j = 2, jjm
    242          DO i =1, iim
    243           zplev( ig0,llmp1 ) = pp(i,j,llmp1)
    244           ig0 = ig0 +1
    245          ENDDO
    246       ENDDO
    247     zplev( ngridmx,llmp1 ) = pp(1,jjp1,llmp1)
     228    DO j = 2, jjm
     229      DO i = 1, iim
     230        zpk(ig0, l) = ppk(i, j, l)
     231        zplev(ig0, l) = pp(i, j, l)
     232        ig0 = ig0 + 1
     233      ENDDO
     234    ENDDO
     235    zpk(ngridmx, l) = ppk(1, jjp1, l)
     236    zplev(ngridmx, l) = pp(1, jjp1, l)
     237  ENDDO
     238  zplev(1, llmp1) = pp(1, 1, llmp1)
     239  ig0 = 2
     240  DO j = 2, jjm
     241    DO i = 1, iim
     242      zplev(ig0, llmp1) = pp(i, j, llmp1)
     243      ig0 = ig0 + 1
     244    ENDDO
     245  ENDDO
     246  zplev(ngridmx, llmp1) = pp(1, jjp1, llmp1)
    248247  !
    249248  !
    … …  
    252251  !   ---------------------------------------------------------------
    253252
    254   DO l=1,llm
    255 
    256      pksurcp     =  ppk(1,1,l) / cpp
    257      zplay(1,l)  = preff * pksurcp ** unskap
    258      ztfi(1,l)   =  pteta(1,1,l) * pksurcp
    259      pcvgt(1,l)  =  pdteta(1,1,l) * pksurcp / pmasse(1,1,l)
    260      ig0        = 2
    261 
    262      DO j = 2, jjm
    263         DO i = 1, iim
    264           pksurcp        = ppk(i,j,l) / cpp
    265           zplay(ig0,l)  = preff * pksurcp ** unskap
    266           ztfi(ig0,l)    = pteta(i,j,l) * pksurcp
    267           pcvgt(ig0,l)   = pdteta(i,j,l) * pksurcp / pmasse(i,j,l)
    268           ig0            = ig0 + 1
    269         ENDDO
    270      ENDDO
    271 
    272      pksurcp       = ppk(1,jjp1,l) / cpp
    273      zplay(ig0,l) = preff * pksurcp ** unskap
    274      ztfi (ig0,l)  = pteta(1,jjp1,l) * pksurcp
    275      pcvgt(ig0,l)  = pdteta(1,jjp1,l) * pksurcp/ pmasse(1,jjp1,l)
     253  DO l = 1, llm
     254
     255    pksurcp = ppk(1, 1, l) / cpp
     256    zplay(1, l) = preff * pksurcp ** unskap
     257    ztfi(1, l) = pteta(1, 1, l) * pksurcp
     258    pcvgt(1, l) = pdteta(1, 1, l) * pksurcp / pmasse(1, 1, l)
     259    ig0 = 2
     260
     261    DO j = 2, jjm
     262      DO i = 1, iim
     263        pksurcp = ppk(i, j, l) / cpp
     264        zplay(ig0, l) = preff * pksurcp ** unskap
     265        ztfi(ig0, l) = pteta(i, j, l) * pksurcp
     266        pcvgt(ig0, l) = pdteta(i, j, l) * pksurcp / pmasse(i, j, l)
     267        ig0 = ig0 + 1
     268      ENDDO
     269    ENDDO
     270
     271    pksurcp = ppk(1, jjp1, l) / cpp
     272    zplay(ig0, l) = preff * pksurcp ** unskap
     273    ztfi (ig0, l) = pteta(1, jjp1, l) * pksurcp
     274    pcvgt(ig0, l) = pdteta(1, jjp1, l) * pksurcp / pmasse(1, jjp1, l)
    276275
    277276  ENDDO
    … …  
    280279  !   ---------------
    281280  !
    282   itr=0
    283   DO iq=1,nqtot
    284      IF(.NOT.tracers(iq)%isAdvected) CYCLE
    285      itr = itr + 1
    286      DO l=1,llm
    287         zqfi(1,l,itr) = pq(1,1,l,iq)
    288         ig0           = 2
    289         DO j=2,jjm
    290            DO i = 1, iim
    291               zqfi(ig0,l,itr) = pq(i,j,l,iq)
    292               ig0             = ig0 + 1
    293            ENDDO
     281  itr = 0
     282  DO iq = 1, nqtot
     283    IF(.NOT.tracers(iq)%isAdvected) CYCLE
     284    itr = itr + 1
     285    DO l = 1, llm
     286      zqfi(1, l, itr) = pq(1, 1, l, iq)
     287      ig0 = 2
     288      DO j = 2, jjm
     289        DO i = 1, iim
     290          zqfi(ig0, l, itr) = pq(i, j, l, iq)
     291          ig0 = ig0 + 1
    294292        ENDDO
    295         zqfi(ig0,l,itr) = pq(1,jjp1,l,iq)
    296      ENDDO
     293      ENDDO
     294      zqfi(ig0, l, itr) = pq(1, jjp1, l, iq)
     295    ENDDO
    297296  ENDDO
    298297
    299298  !   convergence dynamique pour les traceurs "EAU"
    300299  ! Earth-specific treatment of first 2 tracers (water)
    301    IF (planet_type=="earth") THEN
    302     DO iq=1,2
    303      DO l=1,llm
    304         pcvgq(1,l,iq)= pdq(1,1,l,iq) / pmasse(1,1,l)
    305         ig0          = 2
    306         DO j=2,jjm
    307            DO i = 1, iim
    308               pcvgq(ig0,l,iq) = pdq(i,j,l,iq) / pmasse(i,j,l)
    309               ig0            = ig0 + 1
    310            ENDDO
     300  IF (planet_type=="earth") THEN
     301    DO iq = 1, 2
     302      DO l = 1, llm
     303        pcvgq(1, l, iq) = pdq(1, 1, l, iq) / pmasse(1, 1, l)
     304        ig0 = 2
     305        DO j = 2, jjm
     306          DO i = 1, iim
     307            pcvgq(ig0, l, iq) = pdq(i, j, l, iq) / pmasse(i, j, l)
     308            ig0 = ig0 + 1
     309          ENDDO
    311310        ENDDO
    312         pcvgq(ig0,l,iq)= pdq(1,jjp1,l,iq) / pmasse(1,jjp1,l)
    313      ENDDO
    314     ENDDO
    315    endif ! of if (planet_type=="earth")
     311        pcvgq(ig0, l, iq) = pdq(1, jjp1, l, iq) / pmasse(1, jjp1, l)
     312      ENDDO
     313    ENDDO
     314  endif ! of if (planet_type=="earth")
    316315
    317316
    … …  
    319318  !   -----------------------------------------------------
    320319
    321   CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi)
    322   CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis)
    323   DO l=1,llm
    324      DO ig=1,ngridmx
    325        zphi(ig,l)=zphi(ig,l)-zphis(ig)
    326      ENDDO
     320  CALL gr_dyn_fi(llm, iip1, jjp1, ngridmx, pphi, zphi)
     321  CALL gr_dyn_fi(1, iip1, jjp1, ngridmx, pphis, zphis)
     322  DO l = 1, llm
     323    DO ig = 1, ngridmx
     324      zphi(ig, l) = zphi(ig, l) - zphis(ig)
     325    ENDDO
    327326  ENDDO
    328327
    … …  
    330329  ! JG : ancien calcule de omega utilise dans physiq.F. Maintenant le flux
    331330  !    de masse est calclue dans advtrac.F
    332    ! DO l=1,llm
    333    !   pvervel(1,l)=pw(1,1,l) * g /apoln
    334    !   ig0=2
    335    !  DO j=2,jjm
    336    !      DO i = 1, iim
    337    !         pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j)
    338    !         ig0 = ig0 + 1
    339    !      ENDDO
     331  ! DO l=1,llm
     332  !   pvervel(1,l)=pw(1,1,l) * g /apoln
     333  !   ig0=2
     334  !  DO j=2,jjm
     335  !      DO i = 1, iim
     336  !         pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j)
     337  !         ig0 = ig0 + 1
     338  !      ENDDO
    340339  !       ENDDO
    341    !   pvervel(ig0,l)=pw(1,jjp1,l) * g /apols
    342    ! ENDDO
     340  !   pvervel(ig0,l)=pw(1,jjp1,l) * g /apols
     341  ! ENDDO
    343342
    344343  !
    … …  
    346345  !   ------------
    347346
    348   DO l=1,llm
    349 
    350      DO j=2,jjm
    351         ig0 = 1+(j-2)*iim
    352         zufi(ig0+1,l)= 0.5 * &
    353               ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) )
    354         pcvgu(ig0+1,l)= 0.5 * &
    355               ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) )
    356         DO i=2,iim
    357            zufi(ig0+i,l)= 0.5 * &
    358                  ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) )
    359            pcvgu(ig0+i,l)= 0.5 * &
    360                  ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) )
    361   END DO
    362   END DO
     347  DO l = 1, llm
     348
     349    DO j = 2, jjm
     350      ig0 = 1 + (j - 2) * iim
     351      zufi(ig0 + 1, l) = 0.5 * &
     352              (pucov(iim, j, l) / cu(iim, j) + pucov(1, j, l) / cu(1, j))
     353      pcvgu(ig0 + 1, l) = 0.5 * &
     354              (pducov(iim, j, l) / cu(iim, j) + pducov(1, j, l) / cu(1, j))
     355      DO i = 2, iim
     356        zufi(ig0 + i, l) = 0.5 * &
     357                (pucov(i - 1, j, l) / cu(i - 1, j) + pucov(i, j, l) / cu(i, j))
     358        pcvgu(ig0 + i, l) = 0.5 * &
     359                (pducov(i - 1, j, l) / cu(i - 1, j) + pducov(i, j, l) / cu(i, j))
     360      END DO
     361    END DO
    363362
    364363  END DO
    … …  
    368367  !  46.1 Calcul de la vorticite et passage sur la grille physique
    369368  !  --------------------------------------------------------------
    370   DO l=1,llm
    371     do i=1,iim
    372       do j=1,jjm
    373         zrot(i,j,l) = (pvcov(i+1,j,l) - pvcov(i,j,l) &
    374               + pucov(i,j+1,l) - pucov(i,j,l)) &
    375               / (cu(i,j)+cu(i,j+1)) &
    376               / (cv(i+1,j)+cv(i,j)) *4
     369  DO l = 1, llm
     370    do i = 1, iim
     371      do j = 1, jjm
     372        zrot(i, j, l) = (pvcov(i + 1, j, l) - pvcov(i, j, l) &
     373                + pucov(i, j + 1, l) - pucov(i, j, l)) &
     374                / (cu(i, j) + cu(i, j + 1)) &
     375                / (cv(i + 1, j) + cv(i, j)) * 4
    377376      enddo
    378377    enddo
    … …  
    382381  !   -----------
    383382
    384   DO l=1,llm
    385      DO j=2,jjm
    386         ig0=1+(j-2)*iim
    387         DO i=1,iim
    388            zvfi(ig0+i,l)= 0.5 * &
    389                  ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) )
    390            pcvgv(ig0+i,l)= 0.5 * &
    391                  ( pdvcov(i,j-1,l)/cv(i,j-1) + pdvcov(i,j,l)/cv(i,j) )
    392         ENDDO
    393            zrfi(ig0 + 1,l)= 0.25 *(zrot(iim,j-1,l)+zrot(iim,j,l) &
    394                  +zrot(1,j-1,l)+zrot(1,j,l))
    395         DO i=2,iim
    396            zrfi(ig0 + i,l)= 0.25 *(zrot(i-1,j-1,l)+zrot(i-1,j,l) &
    397                  +zrot(i,j-1,l)+zrot(i,j,l))   !  AdlC MAY 2014
    398         ENDDO
    399      ENDDO
     383  DO l = 1, llm
     384    DO j = 2, jjm
     385      ig0 = 1 + (j - 2) * iim
     386      DO i = 1, iim
     387        zvfi(ig0 + i, l) = 0.5 * &
     388                (pvcov(i, j - 1, l) / cv(i, j - 1) + pvcov(i, j, l) / cv(i, j))
     389        pcvgv(ig0 + i, l) = 0.5 * &
     390                (pdvcov(i, j - 1, l) / cv(i, j - 1) + pdvcov(i, j, l) / cv(i, j))
     391      ENDDO
     392      zrfi(ig0 + 1, l) = 0.25 * (zrot(iim, j - 1, l) + zrot(iim, j, l) &
     393              + zrot(1, j - 1, l) + zrot(1, j, l))
     394      DO i = 2, iim
     395        zrfi(ig0 + i, l) = 0.25 * (zrot(i - 1, j - 1, l) + zrot(i - 1, j, l) &
     396                + zrot(i, j - 1, l) + zrot(i, j, l))   !  AdlC MAY 2014
     397      ENDDO
     398    ENDDO
    400399  ENDDO
    401400
    … …  
    403402  !   47. champs de vents aux pole nord
    404403  !   ------------------------------
    405      ! U = 1 / pi  *  integrale [ v * cos(long) * d long ]
    406      ! V = 1 / pi  *  integrale [ v * sin(long) * d long ]
    407 
    408   DO l=1,llm
    409 
    410      z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
    411      z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1)
    412      DO i=2,iim
    413         z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
    414         z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1)
    415      ENDDO
    416 
    417      DO i=1,iim
    418         zcos(i)   = COS(rlonv(i))*z1(i)
    419         zcosbis(i)= COS(rlonv(i))*z1bis(i)
    420         zsin(i)   = SIN(rlonv(i))*z1(i)
    421         zsinbis(i)= SIN(rlonv(i))*z1bis(i)
    422      ENDDO
    423 
    424      zufi(1,l)  = SSUM(iim,zcos,1)/pi
    425      pcvgu(1,l) = SSUM(iim,zcosbis,1)/pi
    426      zvfi(1,l)  = SSUM(iim,zsin,1)/pi
    427      pcvgv(1,l) = SSUM(iim,zsinbis,1)/pi
    428      zrfi(1, l) = 0.
     404  ! U = 1 / pi  *  integrale [ v * cos(long) * d long ]
     405  ! V = 1 / pi  *  integrale [ v * sin(long) * d long ]
     406
     407  DO l = 1, llm
     408
     409    z1(1) = (rlonu(1) - rlonu(iim) + 2. * pi) * pvcov(1, 1, l) / cv(1, 1)
     410    z1bis(1) = (rlonu(1) - rlonu(iim) + 2. * pi) * pdvcov(1, 1, l) / cv(1, 1)
     411    DO i = 2, iim
     412      z1(i) = (rlonu(i) - rlonu(i - 1)) * pvcov(i, 1, l) / cv(i, 1)
     413      z1bis(i) = (rlonu(i) - rlonu(i - 1)) * pdvcov(i, 1, l) / cv(i, 1)
     414    ENDDO
     415
     416    DO i = 1, iim
     417      zcos(i) = COS(rlonv(i)) * z1(i)
     418      zcosbis(i) = COS(rlonv(i)) * z1bis(i)
     419      zsin(i) = SIN(rlonv(i)) * z1(i)
     420      zsinbis(i) = SIN(rlonv(i)) * z1bis(i)
     421    ENDDO
     422
     423    zufi(1, l) = SSUM(iim, zcos, 1) / pi
     424    pcvgu(1, l) = SSUM(iim, zcosbis, 1) / pi
     425    zvfi(1, l) = SSUM(iim, zsin, 1) / pi
     426    pcvgv(1, l) = SSUM(iim, zsinbis, 1) / pi
     427    zrfi(1, l) = 0.
    429428  ENDDO
    430429
    … …  
    432431  !   48. champs de vents aux pole sud:
    433432  !   ---------------------------------
    434      ! U = 1 / pi  *  integrale [ v * cos(long) * d long ]
    435      ! V = 1 / pi  *  integrale [ v * sin(long) * d long ]
    436 
    437   DO l=1,llm
    438 
    439      z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
    440      z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm)
    441      DO i=2,iim
    442         z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
    443         z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm)
    444      ENDDO
    445 
    446      DO i=1,iim
    447         zcos(i)    = COS(rlonv(i))*z1(i)
    448         zcosbis(i) = COS(rlonv(i))*z1bis(i)
    449         zsin(i)    = SIN(rlonv(i))*z1(i)
    450         zsinbis(i) = SIN(rlonv(i))*z1bis(i)
    451      ENDDO
    452 
    453      zufi(ngridmx,l)  = SSUM(iim,zcos,1)/pi
    454      pcvgu(ngridmx,l) = SSUM(iim,zcosbis,1)/pi
    455      zvfi(ngridmx,l)  = SSUM(iim,zsin,1)/pi
    456      pcvgv(ngridmx,l) = SSUM(iim,zsinbis,1)/pi
    457      zrfi(ngridmx, l) = 0.
     433  ! U = 1 / pi  *  integrale [ v * cos(long) * d long ]
     434  ! V = 1 / pi  *  integrale [ v * sin(long) * d long ]
     435
     436  DO l = 1, llm
     437
     438    z1(1) = (rlonu(1) - rlonu(iim) + 2. * pi) * pvcov(1, jjm, l) / cv(1, jjm)
     439    z1bis(1) = (rlonu(1) - rlonu(iim) + 2. * pi) * pdvcov(1, jjm, l) / cv(1, jjm)
     440    DO i = 2, iim
     441      z1(i) = (rlonu(i) - rlonu(i - 1)) * pvcov(i, jjm, l) / cv(i, jjm)
     442      z1bis(i) = (rlonu(i) - rlonu(i - 1)) * pdvcov(i, jjm, l) / cv(i, jjm)
     443    ENDDO
     444
     445    DO i = 1, iim
     446      zcos(i) = COS(rlonv(i)) * z1(i)
     447      zcosbis(i) = COS(rlonv(i)) * z1bis(i)
     448      zsin(i) = SIN(rlonv(i)) * z1(i)
     449      zsinbis(i) = SIN(rlonv(i)) * z1bis(i)
     450    ENDDO
     451
     452    zufi(ngridmx, l) = SSUM(iim, zcos, 1) / pi
     453    pcvgu(ngridmx, l) = SSUM(iim, zcosbis, 1) / pi
     454    zvfi(ngridmx, l) = SSUM(iim, zsin, 1) / pi
     455    pcvgv(ngridmx, l) = SSUM(iim, zsinbis, 1) / pi
     456    zrfi(ngridmx, l) = 0.
    458457  ENDDO
    459458  !
    460459  ! On change de grille, dynamique vers physiq, pour le flux de masse verticale
    461   CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi)
     460  CALL gr_dyn_fi(llm, iip1, jjp1, ngridmx, flxw, flxwfi)
    462461
    463462  !-----------------------------------------------------------------------
    … …  
    467466
    468467
    469    ! WRITE(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
    470   zdt_split=dtphys/nsplit_phys
    471   zdufic(:,:)=0.
    472   zdvfic(:,:)=0.
    473   zdtfic(:,:)=0.
    474   zdqfic(:,:,:)=0.
    475 
    476    IF (CPPKEY_PHYS) THEN
    477 
    478    do isplit=1,nsplit_phys
    479 
    480      jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys)
    481      debut_split=debut.AND.isplit==1
    482      lafin_split=lafin.AND.isplit==nsplit_phys
    483 
    484    ! if (planet_type=="earth") THEN
    485     CALL call_physiq(ngridmx,llm,nqtot,tracers(:)%name, &
    486           debut_split,lafin_split, &
    487           jD_cur,jH_cur_split,zdt_split, &
    488           zplev,zplay, &
    489           zpk,zphi,zphis, &
    490           presnivs, &
    491           zufi,zvfi,zrfi,ztfi,zqfi, &
    492           flxwfi,pducov, &
    493           zdufi,zdvfi,zdtfi,zdqfi,zdpsrf)
    494 
    495    ! ELSE IF ( planet_type=="generic" ) THEN
    496    !    CALL physiq (ngridmx,     !! ngrid
    497   ! .             llm,            !! nlayer
    498   ! .             nqtot,          !! nq
    499   ! .             tracers(:)%name,!! tracer names from dynamical core (given in infotrac)
    500   ! .             debut_split,    !! firstcall
    501   ! .             lafin_split,    !! lastcall
    502   ! .             jD_cur,         !! pday. see leapfrog
    503   ! .             jH_cur_split,   !! ptime "fraction of day"
    504   ! .             zdt_split,      !! ptimestep
    505   ! .             zplev,          !! pplev
    506   ! .             zplay,          !! pplay
    507   ! .             zphi,           !! pphi
    508   ! .             zufi,           !! pu
    509   ! .             zvfi,           !! pv
    510   ! .             ztfi,           !! pt
    511   ! .             zqfi,           !! pq
    512   ! .             flxwfi,         !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
    513   ! .             zdufi,          !! pdu
    514   ! .             zdvfi,          !! pdv
    515   ! .             zdtfi,          !! pdt
    516   ! .             zdqfi,          !! pdq
    517   ! .             zdpsrf,         !! pdpsrf
    518   ! .             tracerdyn)      !! tracerdyn <-- utilite ???
    519 
    520   !  ENDIF ! of if (planet_type=="earth")
    521 
    522      zufi(:,:)=zufi(:,:)+zdufi(:,:)*zdt_split
    523      zvfi(:,:)=zvfi(:,:)+zdvfi(:,:)*zdt_split
    524      ztfi(:,:)=ztfi(:,:)+zdtfi(:,:)*zdt_split
    525      zqfi(:,:,:)=zqfi(:,:,:)+zdqfi(:,:,:)*zdt_split
    526 
    527      zdufic(:,:)=zdufic(:,:)+zdufi(:,:)
    528      zdvfic(:,:)=zdvfic(:,:)+zdvfi(:,:)
    529      zdtfic(:,:)=zdtfic(:,:)+zdtfi(:,:)
    530      zdqfic(:,:,:)=zdqfic(:,:,:)+zdqfi(:,:,:)
    531 
    532    enddo ! of do isplit=1,nsplit_phys
    533 
    534    END IF
    535 
    536   zdufi(:,:)=zdufic(:,:)/nsplit_phys
    537   zdvfi(:,:)=zdvfic(:,:)/nsplit_phys
    538   zdtfi(:,:)=zdtfic(:,:)/nsplit_phys
    539   zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys
     468  ! WRITE(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
     469  zdt_split = dtphys / nsplit_phys
     470  zdufic(:, :) = 0.
     471  zdvfic(:, :) = 0.
     472  zdtfic(:, :) = 0.
     473  zdqfic(:, :, :) = 0.
     474
     475  IF (CPPKEY_PHYS) THEN
     476
     477    do isplit = 1, nsplit_phys
     478
     479      jH_cur_split = jH_cur + (isplit - 1) * dtvr / (daysec * nsplit_phys)
     480      debut_split = debut.AND.isplit==1
     481      lafin_split = lafin.AND.isplit==nsplit_phys
     482
     483      ! if (planet_type=="earth") THEN
     484      CALL call_physiq(ngridmx, llm, nqtot, tracers(:)%name, &
     485              debut_split, lafin_split, &
     486              jD_cur, jH_cur_split, zdt_split, &
     487              zplev, zplay, &
     488              zpk, zphi, zphis, &
     489              presnivs, &
     490              zufi, zvfi, zrfi, ztfi, zqfi, &
     491              flxwfi, pducov, &
     492              zdufi, zdvfi, zdtfi, zdqfi, zdpsrf)
     493
     494      ! ELSE IF ( planet_type=="generic" ) THEN
     495      !    CALL physiq (ngridmx,     !! ngrid
     496      ! .             llm,            !! nlayer
     497      ! .             nqtot,          !! nq
     498      ! .             tracers(:)%name,!! tracer names from dynamical core (given in infotrac)
     499      ! .             debut_split,    !! firstcall
     500      ! .             lafin_split,    !! lastcall
     501      ! .             jD_cur,         !! pday. see leapfrog
     502      ! .             jH_cur_split,   !! ptime "fraction of day"
     503      ! .             zdt_split,      !! ptimestep
     504      ! .             zplev,          !! pplev
     505      ! .             zplay,          !! pplay
     506      ! .             zphi,           !! pphi
     507      ! .             zufi,           !! pu
     508      ! .             zvfi,           !! pv
     509      ! .             ztfi,           !! pt
     510      ! .             zqfi,           !! pq
     511      ! .             flxwfi,         !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
     512      ! .             zdufi,          !! pdu
     513      ! .             zdvfi,          !! pdv
     514      ! .             zdtfi,          !! pdt
     515      ! .             zdqfi,          !! pdq
     516      ! .             zdpsrf,         !! pdpsrf
     517      ! .             tracerdyn)      !! tracerdyn <-- utilite ???
     518
     519      !  ENDIF ! of if (planet_type=="earth")
     520
     521      zufi(:, :) = zufi(:, :) + zdufi(:, :) * zdt_split
     522      zvfi(:, :) = zvfi(:, :) + zdvfi(:, :) * zdt_split
     523      ztfi(:, :) = ztfi(:, :) + zdtfi(:, :) * zdt_split
     524      zqfi(:, :, :) = zqfi(:, :, :) + zdqfi(:, :, :) * zdt_split
     525
     526      zdufic(:, :) = zdufic(:, :) + zdufi(:, :)
     527      zdvfic(:, :) = zdvfic(:, :) + zdvfi(:, :)
     528      zdtfic(:, :) = zdtfic(:, :) + zdtfi(:, :)
     529      zdqfic(:, :, :) = zdqfic(:, :, :) + zdqfi(:, :, :)
     530
     531    enddo ! of do isplit=1,nsplit_phys
     532
     533  END IF
     534
     535  zdufi(:, :) = zdufic(:, :) / nsplit_phys
     536  zdvfi(:, :) = zdvfic(:, :) / nsplit_phys
     537  zdtfi(:, :) = zdtfic(:, :) / nsplit_phys
     538  zdqfi(:, :, :) = zdqfic(:, :, :) / nsplit_phys
    540539
    541540  !-----------------------------------------------------------------------
    … …  
    546545  !  -----------------------------------
    547546
    548   CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi)
     547  CALL gr_fi_dyn(1, ngridmx, iip1, jjp1, zdpsrf, pdpsfi)
    549548  !
    550549  !   62. enthalpie potentielle
    551550  !   ---------------------
    552551
    553   DO l=1,llm
    554 
    555      DO i=1,iip1
    556       pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
    557       pdhfi(i,jjp1,l) = cpp *  zdtfi(ngridmx,l)/ ppk(i,jjp1,l)
    558      ENDDO
    559 
    560      DO j=2,jjm
    561         ig0=1+(j-2)*iim
    562         DO i=1,iim
    563            pdhfi(i,j,l) = cpp * zdtfi(ig0+i,l) / ppk(i,j,l)
    564         ENDDO
    565            pdhfi(iip1,j,l) =  pdhfi(1,j,l)
    566      ENDDO
     552  DO l = 1, llm
     553
     554    DO i = 1, iip1
     555      pdhfi(i, 1, l) = cpp * zdtfi(1, l) / ppk(i, 1, l)
     556      pdhfi(i, jjp1, l) = cpp * zdtfi(ngridmx, l) / ppk(i, jjp1, l)
     557    ENDDO
     558
     559    DO j = 2, jjm
     560      ig0 = 1 + (j - 2) * iim
     561      DO i = 1, iim
     562        pdhfi(i, j, l) = cpp * zdtfi(ig0 + i, l) / ppk(i, j, l)
     563      ENDDO
     564      pdhfi(iip1, j, l) = pdhfi(1, j, l)
     565    ENDDO
    567566
    568567  ENDDO
    … …  
    572571  !   ---------------------
    573572  ! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
    574    ! DO iq=1,nqtot
    575    !    DO l=1,llm
    576    !       DO i=1,iip1
    577    !          pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)
    578    !          pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq)
    579    !       ENDDO
    580    !       DO j=2,jjm
    581    !          ig0=1+(j-2)*iim
    582    !          DO i=1,iim
    583    !             pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq)
    584    !          ENDDO
    585    !          pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq)
    586    !       ENDDO
    587    !    ENDDO
    588    ! ENDDO
     573  ! DO iq=1,nqtot
     574  !    DO l=1,llm
     575  !       DO i=1,iip1
     576  !          pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)
     577  !          pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq)
     578  !       ENDDO
     579  !       DO j=2,jjm
     580  !          ig0=1+(j-2)*iim
     581  !          DO i=1,iim
     582  !             pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq)
     583  !          ENDDO
     584  !          pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq)
     585  !       ENDDO
     586  !    ENDDO
     587  ! ENDDO
    589588
    590589  !   63. traceurs
    591590  !   ------------
    592591  ! initialisation des tendances
    593   pdqfi(:,:,:,:)=0.
     592  pdqfi(:, :, :, :) = 0.
    594593  !
    595594  itr = 0
    596   DO iq=1,nqtot
    597      IF(.NOT.tracers(iq)%isAdvected) CYCLE
    598      itr = itr + 1
    599      DO l=1,llm
    600         DO i=1,iip1
    601            pdqfi(i,1,l,iq)    = zdqfi(1,l,itr)
    602            pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,itr)
     595  DO iq = 1, nqtot
     596    IF(.NOT.tracers(iq)%isAdvected) CYCLE
     597    itr = itr + 1
     598    DO l = 1, llm
     599      DO i = 1, iip1
     600        pdqfi(i, 1, l, iq) = zdqfi(1, l, itr)
     601        pdqfi(i, jjp1, l, iq) = zdqfi(ngridmx, l, itr)
     602      ENDDO
     603      DO j = 2, jjm
     604        ig0 = 1 + (j - 2) * iim
     605        DO i = 1, iim
     606          pdqfi(i, j, l, iq) = zdqfi(ig0 + i, l, itr)
    603607        ENDDO
    604         DO j=2,jjm
    605            ig0=1+(j-2)*iim
    606            DO i=1,iim
    607               pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,itr)
    608            ENDDO
    609            pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,itr)
    610         ENDDO
    611      ENDDO
     608        pdqfi(iip1, j, l, iq) = pdqfi(1, j, l, itr)
     609      ENDDO
     610    ENDDO
    612611  ENDDO
    613612
    … …  
    615614  !   ------------
    616615
    617   DO l=1,llm
    618 
    619      DO i=1,iip1
    620         pdufi(i,1,l)    = 0.
    621         pdufi(i,jjp1,l) = 0.
    622      ENDDO
    623 
    624      DO j=2,jjm
    625         ig0=1+(j-2)*iim
    626         DO i=1,iim-1
    627            pdufi(i,j,l)= &
    628                  0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j)
    629         ENDDO
    630         pdufi(iim,j,l)= &
    631               0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j)
    632         pdufi(iip1,j,l)=pdufi(1,j,l)
    633      ENDDO
     616  DO l = 1, llm
     617
     618    DO i = 1, iip1
     619      pdufi(i, 1, l) = 0.
     620      pdufi(i, jjp1, l) = 0.
     621    ENDDO
     622
     623    DO j = 2, jjm
     624      ig0 = 1 + (j - 2) * iim
     625      DO i = 1, iim - 1
     626        pdufi(i, j, l) = &
     627                0.5 * (zdufi(ig0 + i, l) + zdufi(ig0 + i + 1, l)) * cu(i, j)
     628      ENDDO
     629      pdufi(iim, j, l) = &
     630              0.5 * (zdufi(ig0 + 1, l) + zdufi(ig0 + iim, l)) * cu(iim, j)
     631      pdufi(iip1, j, l) = pdufi(1, j, l)
     632    ENDDO
    634633
    635634  ENDDO
    … …  
    639638  !   ------------
    640639
    641   DO l=1,llm
    642 
    643      DO j=2,jjm-1
    644         ig0=1+(j-2)*iim
    645         DO i=1,iim
    646            pdvfi(i,j,l)= &
    647                  0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j)
    648         ENDDO
    649         pdvfi(iip1,j,l) = pdvfi(1,j,l)
    650      ENDDO
     640  DO l = 1, llm
     641
     642    DO j = 2, jjm - 1
     643      ig0 = 1 + (j - 2) * iim
     644      DO i = 1, iim
     645        pdvfi(i, j, l) = &
     646                0.5 * (zdvfi(ig0 + i, l) + zdvfi(ig0 + i + iim, l)) * cv(i, j)
     647      ENDDO
     648      pdvfi(iip1, j, l) = pdvfi(1, j, l)
     649    ENDDO
    651650  ENDDO
    652651
    … …  
    654653  !   68. champ v pres des poles:
    655654  !   ---------------------------
    656    ! v = U * cos(long) + V * SIN(long)
    657 
    658   DO l=1,llm
    659 
    660      DO i=1,iim
    661         pdvfi(i,1,l)= &
    662               zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i))
    663         pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i)) &
    664               +zdvfi(ngridmx,l)*SIN(rlonv(i))
    665         pdvfi(i,1,l)= &
    666               0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
    667         pdvfi(i,jjm,l)= &
    668               0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm)
    669       ENDDO
    670 
    671      pdvfi(iip1,1,l)  = pdvfi(1,1,l)
    672      pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
     655  ! v = U * cos(long) + V * SIN(long)
     656
     657  DO l = 1, llm
     658
     659    DO i = 1, iim
     660      pdvfi(i, 1, l) = &
     661              zdufi(1, l) * COS(rlonv(i)) + zdvfi(1, l) * SIN(rlonv(i))
     662      pdvfi(i, jjm, l) = zdufi(ngridmx, l) * COS(rlonv(i)) &
     663              + zdvfi(ngridmx, l) * SIN(rlonv(i))
     664      pdvfi(i, 1, l) = &
     665              0.5 * (pdvfi(i, 1, l) + zdvfi(i + 1, l)) * cv(i, 1)
     666      pdvfi(i, jjm, l) = &
     667              0.5 * (pdvfi(i, jjm, l) + zdvfi(ngridmx - iip1 + i, l)) * cv(i, jjm)
     668    ENDDO
     669
     670    pdvfi(iip1, 1, l) = pdvfi(1, 1, l)
     671    pdvfi(iip1, jjm, l) = pdvfi(1, jjm, l)
    673672
    674673  ENDDO

  • LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_dyn_fi.f90

    r5116 r5119  
    1 
    21! $Header$
    32
    4 SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi)
     3SUBROUTINE gr_dyn_fi(nfield, im, jm, ngrid, pdyn, pfi)
     4  USE lmdz_ssum_scopy, ONLY: scopy
     5
    56  IMPLICIT NONE
    67  !=======================================================================
    … …  
    1213  !   -------------
    1314
    14   INTEGER :: im,jm,ngrid,nfield
    15   REAL :: pdyn(im,jm,nfield)
    16   REAL :: pfi(ngrid,nfield)
     15  INTEGER :: im, jm, ngrid, nfield
     16  REAL :: pdyn(im, jm, nfield)
     17  REAL :: pfi(ngrid, nfield)
    1718
    18   INTEGER :: j,ifield,ig
     19  INTEGER :: j, ifield, ig
    1920
    2021  !-----------------------------------------------------------------------
    … …  
    2223  !   -------
    2324
    24   IF (ngrid/=2+(jm-2)*(im-1)) THEN
    25      CALL abort_gcm("gr_dyn_fi", 'probleme de dim', 1)
     25  IF (ngrid/=2 + (jm - 2) * (im - 1)) THEN
     26    CALL abort_gcm("gr_dyn_fi", 'probleme de dim', 1)
    2627  end if
    2728  !   traitement des poles
    28   CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid)
    29   CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid)
     29  CALL SCOPY(nfield, pdyn, im * jm, pfi, ngrid)
     30  CALL SCOPY(nfield, pdyn(1, jm, 1), im * jm, pfi(ngrid, 1), ngrid)
    3031
    3132  !   traitement des point normaux
    32   DO ifield=1,nfield
    33      DO j=2,jm-1
    34         ig=2+(j-2)*(im-1)
    35         CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1)
    36      ENDDO
     33  DO ifield = 1, nfield
     34    DO j = 2, jm - 1
     35      ig = 2 + (j - 2) * (im - 1)
     36      CALL SCOPY(im - 1, pdyn(1, j, ifield), 1, pfi(ig, ifield), 1)
     37    ENDDO
    3738  ENDDO
    3839

  • LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/gr_fi_dyn.f90

    r5105 r5119  
    1 
    21! $Header$
    32
    4 SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn)
     3SUBROUTINE gr_fi_dyn(nfield, ngrid, im, jm, pfi, pdyn)
     4  USE lmdz_ssum_scopy, ONLY: scopy
     5
    56  IMPLICIT NONE
    67  !=======================================================================
    … …  
    1213  !   -------------
    1314
    14   INTEGER :: im,jm,ngrid,nfield
    15   REAL :: pdyn(im,jm,nfield)
    16   REAL :: pfi(ngrid,nfield)
     15  INTEGER :: im, jm, ngrid, nfield
     16  REAL :: pdyn(im, jm, nfield)
     17  REAL :: pfi(ngrid, nfield)
    1718
    18   INTEGER :: i,j,ifield,ig
     19  INTEGER :: i, j, ifield, ig
    1920
    2021  !-----------------------------------------------------------------------
    … …  
    2223  !   -------
    2324
    24   DO ifield=1,nfield
    25   !   traitement des poles
    26      DO i=1,im
    27         pdyn(i,1,ifield)=pfi(1,ifield)
    28         pdyn(i,jm,ifield)=pfi(ngrid,ifield)
    29      ENDDO
     25  DO ifield = 1, nfield
     26    !   traitement des poles
     27    DO i = 1, im
     28      pdyn(i, 1, ifield) = pfi(1, ifield)
     29      pdyn(i, jm, ifield) = pfi(ngrid, ifield)
     30    ENDDO
    3031
    31   !   traitement des point normaux
    32      DO j=2,jm-1
    33         ig=2+(j-2)*(im-1)
    34         CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1)
    35         pdyn(im,j,ifield)=pdyn(1,j,ifield)
    36      ENDDO
     32    !   traitement des point normaux
     33    DO j = 2, jm - 1
     34      ig = 2 + (j - 2) * (im - 1)
     35      CALL SCOPY(im - 1, pfi(ig, ifield), 1, pdyn(1, j, ifield), 1)
     36      pdyn(im, j, ifield) = pdyn(1, j, ifield)
     37    ENDDO
    3738  ENDDO
    3839

  • LMDZ6/branches/Amaury_dev/libf/dynphy_lonlat/phylmd/test_disvert_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  SUBROUTINE test_disvert
    … …  
    6565  END SUBROUTINE  test_disvert
    6666
    67 end module test_disvert_m
     67END MODULE test_disvert_m

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_TO_MOVE_ssum_scopy.f90

    r5117 r5119  
    33! Those are old legacy CRAY replacement functions, that are now used in several parts of the code.
    44
    5 SUBROUTINE scopy(n, sx, incx, sy, incy)
     5MODULE lmdz_ssum_scopy
     6  IMPLICIT NONE; PRIVATE
     7  PUBLIC ssum, scopy
     8CONTAINS
    69
    7   IMPLICIT NONE
     10  SUBROUTINE scopy(n, sx, incx, sy, incy)
    811
    9   INTEGER n, incx, incy, ix, iy, i
    10   REAL sx((n - 1) * incx + 1), sy((n - 1) * incy + 1)
     12    IMPLICIT NONE
    1113
    12   iy = 1
    13   ix = 1
    14   DO i = 1, n
    15     sy(iy) = sx(ix)
    16     ix = ix + incx
    17     iy = iy + incy
    18   END DO
     14    INTEGER n, incx, incy, ix, iy, i
     15    REAL sx((n - 1) * incx + 1), sy((n - 1) * incy + 1)
    1916
    20 end
     17    iy = 1
     18    ix = 1
     19    DO i = 1, n
     20      sy(iy) = sx(ix)
     21      ix = ix + incx
     22      iy = iy + incy
     23    END DO
    2124
    22 function ssum(n, sx, incx)
     25  end
    2326
    24   IMPLICIT NONE
     27  function ssum(n, sx, incx)
    2528
    26   INTEGER n, incx, i, ix
    27   REAL ssum, sx((n - 1) * incx + 1)
     29    IMPLICIT NONE
    2830
    29   ssum = 0.
    30   ix = 1
    31   do i = 1, n
    32     ssum = ssum + sx(ix)
    33     ix = ix + incx
    34   END DO
     31    INTEGER n, incx, i, ix
     32    REAL ssum, sx((n - 1) * incx + 1)
    3533
    36 end
     34    ssum = 0.
     35    ix = 1
     36    do i = 1, n
     37      ssum = ssum + sx(ix)
     38      ix = ix + incx
     39    END DO
    3740
     41  end
     42
     43END MODULE lmdz_ssum_scopy

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_assert.f90

    r5117 r5119  
    22MODULE lmdz_assert
    33
    4   IMPLICIT NONE
    5 
     4  IMPLICIT NONE; PRIVATE
     5  PUBLIC assert
    66  INTERFACE assert
    77    MODULE PROCEDURE assert1, assert2, assert3, assert4, assert_v
    88  END INTERFACE
    9 
    10   PRIVATE assert1, assert2, assert3, assert4, assert_v
    119
    1210CONTAINS

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_assert_eq.f90

    r5117 r5119  
    11MODULE lmdz_assert_eq
    22
    3   IMPLICIT NONE
     3  IMPLICIT NONE; PRIVATE
     4  PUBLIC assert_eq
    45
    56  INTERFACE assert_eq
    67    MODULE PROCEDURE assert_eq2, assert_eq3, assert_eq4, assert_eqn
    78  END INTERFACE
    8 
    9   PRIVATE assert_eq2, assert_eq3, assert_eq4, assert_eqn
    109
    1110CONTAINS

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_coefpoly.f90

    r5117 r5119  
    44  PUBLIC coefpoly
    55
    6 contains
     6CONTAINS
    77
    88  SUBROUTINE coefpoly(xf1, xf2, xprim1, xprim2, xtild1, xtild2, a0, a1, a2, a3)
    … …  
    5151  END SUBROUTINE coefpoly
    5252
    53 end module lmdz_coefpoly
     53END MODULE lmdz_coefpoly

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_interpolation.f90

    r5117 r5119  
    88  PUBLIC locate, hunt
    99
    10 contains
     10CONTAINS
    1111
    1212  pure FUNCTION locate(xx, x)
    … …  
    137137  END SUBROUTINE hunt
    138138
    139 end module lmdz_interpolation
     139END MODULE lmdz_interpolation

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_mpi_wrappers.F90

    r5103 r5119  
    1414
    1515SUBROUTINE MPI_ALLGATHER(SENDBUF, SENDCOUNT, SENDTYPE, RECVBUF, RECVCOUNT, RECVTYPE, COMM, IERROR)
    16 USE ISO_C_BINDING
     16USE ISO_C_BINDING, ONLY: C_PTR
    1717IMPLICIT NONE
    1818    TYPE(C_PTR),VALUE  ::   SENDBUF , RECVBUF
    … …  
    4141
    4242SUBROUTINE MPI_ISEND(BUF, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR)
    43 USE ISO_C_BINDING
     43USE ISO_C_BINDING, ONLY: C_PTR
    4444IMPLICIT NONE
    4545    TYPE(C_PTR),VALUE  ::    BUF
    … …  
    5050
    5151SUBROUTINE MPI_ISSEND(BUF, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR)
    52 USE ISO_C_BINDING
     52USE ISO_C_BINDING, ONLY: C_PTR
    5353IMPLICIT NONE
    5454    TYPE(C_PTR),VALUE  ::    BUF
    … …  
    5858
    5959SUBROUTINE MPI_IRECV(BUF, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR)
    60 USE ISO_C_BINDING
     60USE ISO_C_BINDING, ONLY: C_PTR
    6161IMPLICIT NONE
    6262    TYPE(C_PTR),VALUE  ::    BUF
    … …  
    7474
    7575SUBROUTINE MPI_GATHERV(SENDBUF, SENDCOUNT, SENDTYPE, RECVBUF, RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR)
    76 USE ISO_C_BINDING
     76USE ISO_C_BINDING, ONLY: C_PTR
    7777IMPLICIT NONE
    7878    TYPE(C_PTR),VALUE  ::    SENDBUF, RECVBUF
    … …  
    8383   
    8484SUBROUTINE MPI_BCAST(BUFFER, COUNT, DATATYPE, ROOT, COMM, IERROR)
    85 USE ISO_C_BINDING
     85USE ISO_C_BINDING, ONLY: C_PTR
    8686IMPLICIT NONE
    8787    TYPE(C_PTR),VALUE  ::    BUFFER
    … …  
    9191
    9292SUBROUTINE MPI_ALLREDUCE(SENDBUF, RECVBUF, COUNT, DATATYPE, OP, COMM, IERROR)
    93 USE ISO_C_BINDING
     93USE ISO_C_BINDING, ONLY: C_PTR
    9494IMPLICIT NONE
    9595    TYPE(C_PTR),VALUE  ::    SENDBUF, RECVBUF
    … …  
    113113
    114114SUBROUTINE MPI_SCATTERV(SENDBUF, SENDCOUNTS, DISPLS, SENDTYPE, RECVBUF, RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR)
    115 USE ISO_C_BINDING
     115USE ISO_C_BINDING, ONLY: C_PTR
    116116IMPLICIT NONE
    117117    TYPE(C_PTR),VALUE  ::    SENDBUF, RECVBUF
    … …  
    122122
    123123SUBROUTINE MPI_REDUCE(SENDBUF, RECVBUF, COUNT, DATATYPE, OP, ROOT, COMM, IERROR)
    124 USE ISO_C_BINDING
     124USE ISO_C_BINDING, ONLY: C_PTR
    125125IMPLICIT NONE
    126126    TYPE(C_PTR),VALUE ::    SENDBUF, RECVBUF
    … …  
    130130
    131131SUBROUTINE MPI_RECV(BUF, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR)
    132 USE ISO_C_BINDING
     132USE ISO_C_BINDING, ONLY: C_PTR
    133133USE lmdz_mpi, ONLY: MPI_STATUS_SIZE
    134134IMPLICIT NONE
    … …  
    140140
    141141SUBROUTINE MPI_SEND(BUF, COUNT, DATATYPE, DEST, TAG, COMM, IERROR)
    142 USE ISO_C_BINDING
     142USE ISO_C_BINDING, ONLY: C_PTR
    143143IMPLICIT NONE
    144144    TYPE(C_PTR),VALUE  ::  BUF
    … …  
    155155
    156156SUBROUTINE MPI_GATHER(SENDBUF, SENDCOUNT, SENDTYPE, RECVBUF, RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR)
    157 USE ISO_C_BINDING
     157USE ISO_C_BINDING, ONLY: C_PTR
    158158IMPLICIT NONE
    159159    TYPE(C_PTR),VALUE  ::  SENDBUF, RECVBUF

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_new_unit.f90

    r5117 r5119  
    11module lmdz_new_unit
    22
    3   IMPLICIT NONE
     3  IMPLICIT NONE; PRIVATE
     4  PUBLIC new_unit
    45
    5 contains
     6CONTAINS
    67
    78  ! Returns an existing unit id that isn't already opened
    … …  
    2021  END SUBROUTINE  new_unit
    2122
    22 end module lmdz_new_unit
     23END MODULE lmdz_new_unit

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_physical_constants.f90

    r5117 r5119  
    11MODULE lmdz_physical_constants
    22
    3   IMPLICIT NONE
     3  IMPLICIT NONE; PRIVATE
     4  PUBLIC k8, PI, PIO2, TWOPI, SQRT2, EULER, PI_D, PIO2_D, TWOPI_D
    45
    56  INTEGER, parameter :: k8 = selected_real_kind(13)

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_regr_conserv.f90

    r5117 r5119  
    55  USE lmdz_interpolation, ONLY: locate
    66
    7   IMPLICIT NONE
     7  IMPLICIT NONE; PRIVATE
     8  PUBLIC :: regr_conserv
    89
    910! Purpose: Each procedure regrids a piecewise linear function (not necessarily
    … …  
    3435  END INTERFACE
    3536
    36   PRIVATE
    37   PUBLIC :: regr_conserv
    38 
    3937CONTAINS
    4038

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_regr_lint.f90

    r5117 r5119  
    55  USE lmdz_interpolation, ONLY: hunt
    66
    7   IMPLICIT NONE
     7  IMPLICIT NONE; PRIVATE
     8  PUBLIC :: regr_lint
    89
    910  ! Purpose: Each procedure regrids by linear interpolation along dimension "ix"
    … …  
    2627  END INTERFACE
    2728
    28   PRIVATE
    29   PUBLIC :: regr_lint
    3029
    3130CONTAINS

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_slopes.f90

    r5117 r5119  
    44  ! Extension / factorisation: David CUGNET
    55
    6   IMPLICIT NONE
     6  IMPLICIT NONE; PRIVATE
     7  PUBLIC :: slopes
    78
    89  ! Those generic function computes second order slopes with Van
    … …  
    2324  END INTERFACE
    2425
    25   PRIVATE
    26   PUBLIC :: slopes
     26
    2727
    2828CONTAINS

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_vampir.F90

    r5117 r5119  
    1313  INTEGER :: MPE_end(nb_inst)
    1414
    15 contains
     15CONTAINS
    1616
    1717  SUBROUTINE InitVampir
    … …  
    8484  END SUBROUTINE  VTe
    8585
    86 end module lmdz_vampir
     86END MODULE lmdz_vampir

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_write_field.f90

    r5117 r5119  
    1919    module procedure WriteField3d, WriteField2d, WriteField1d
    2020  end interface WriteField
    21 contains
     21CONTAINS
    2222
    2323  function GetFieldIndex(name)
    … …  
    298298  END SUBROUTINE write_field3D
    299299
    300 end module lmdz_write_field
     300END MODULE lmdz_write_field
    301301 

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_wxios.F90

    r5118 r5119  
    442442    USE lmdz_geometry, ONLY: longitude, latitude, boundslon, boundslat, ind_cell_glo
    443443    USE lmdz_grid_phy, ONLY: nvertex, klon_glo
    444     USE lmdz_phys_para
    445444    USE lmdz_physical_constants, ONLY: PI
    446445    USE lmdz_ioipsl_getin_p, ONLY: getin_p

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_xios.F90

    r5066 r5119  
    22
    33MODULE lmdz_xios
    4   USE xios
     4  USE xios  ! no ONLY, on purpose
    55 
    66  LOGICAL,PARAMETER :: using_xios = .TRUE.
    … …  
    1414  !! => must be replaced later by official xios wrapper when available
    1515
    16   LOGICAL,PARAMETER :: using_xios = .FALSE.
    17 
    18 INTERFACE xios_send_field
    19   MODULE PROCEDURE xios_send_field_scalar, xios_send_field_1d, xios_send_field_2d, xios_send_field_3d, &
    20                    xios_send_field_4d, xios_send_field_5d
    21 END INTERFACE  xios_send_field
    22 
    23 INTERFACE xios_recv_field
    24   MODULE PROCEDURE xios_recv_field_scalar, xios_recv_field_1d, xios_recv_field_2d, xios_recv_field_3d, &
    25                    xios_recv_field_4d
    26 END INTERFACE  xios_recv_field
    27 
    28 INTERFACE xios_field_is_active
    29   MODULE PROCEDURE xios_field_is_active_id,xios_field_is_active_hdl
    30 END INTERFACE xios_field_is_active
    31 
    32 INTERFACE xios_set_attr
    33   MODULE PROCEDURE xios_set_fieldgroup_attr_hdl, xios_set_field_attr_hdl, xios_set_domain_attr_hdl, &
    34                    xios_set_axis_attr_hdl, xios_set_file_attr_hdl
    35 END INTERFACE  xios_set_attr
    36 
    37 INTERFACE xios_get_handle
    38   MODULE PROCEDURE  xios_get_context_handle, xios_get_field_handle, xios_get_fieldgroup_handle, &
    39                     xios_get_domain_handle,xios_get_file_handle, xios_get_filegroup_handle
    40 END INTERFACE  xios_get_handle
    41 
    42 INTERFACE xios_add_child
    43   MODULE PROCEDURE xios_fieldgroup_add_child, xios_add_fieldtofile, xios_add_file
    44 END INTERFACE  xios_add_child
    45 
    46 INTERFACE xios_set_current_context
    47       MODULE PROCEDURE xios_set_current_context_hdl, xios_set_current_context_id
    48 END INTERFACE xios_set_current_context
    49 
    50 INTERFACE xios_get_current_context
    51       MODULE PROCEDURE xios_get_current_context_hdl, xios_get_current_context_id
    52 END INTERFACE xios_get_current_context
    53 
    54 INTERFACE xios_set_start_date
    55   MODULE PROCEDURE xios_set_start_date_date, xios_set_start_date_dur
    56 END INTERFACE xios_set_start_date
    57 
    58 INTERFACE xios_set_time_origin
    59   MODULE PROCEDURE xios_set_time_origin_date, xios_set_time_origin_dur
    60 END INTERFACE xios_set_time_origin
    61 
    62 INTERFACE xios_is_defined_attr
    63   MODULE PROCEDURE xios_is_defined_domain_attr_hdl
    64 END INTERFACE xios_is_defined_attr
    65 
    66 TYPE xios_duration
    67   DOUBLE PRECISION :: year=0, month=0, day=0, hour=0, minute=0, second=0, timestep=0
    68 END TYPE xios_duration
    69 
    70 TYPE xios_date
    71   INTEGER :: year=0, month=0, day=0, hour=0, minute=0, second=0
    72 END TYPE xios_date
    73 
    74    
    75 REAL,PARAMETER :: xios_timestep=1.
    76 REAL,PARAMETER :: xios_second=1.
    77 
    78 TYPE xios_fieldgroup
    79 END TYPE xios_fieldgroup
    80 
    81 TYPE xios_filegroup
    82 END TYPE xios_filegroup
    83 
    84 TYPE xios_context
    85 END TYPE xios_context
    86 
    87 TYPE xios_domain
    88 END TYPE xios_domain
    89 
    90 TYPE xios_axis
    91 END TYPE xios_axis
    92 
    93 TYPE xios_file
    94 END TYPE xios_file
    95 
    96 TYPE xios_field
    97 END TYPE
    98 
    99 
    100 CONTAINS 
    101  
    102  
     16  LOGICAL, PARAMETER :: using_xios = .FALSE.
     17
     18  INTERFACE xios_send_field
     19    MODULE PROCEDURE xios_send_field_scalar, xios_send_field_1d, xios_send_field_2d, xios_send_field_3d, &
     20            xios_send_field_4d, xios_send_field_5d
     21  END INTERFACE  xios_send_field
     22
     23  INTERFACE xios_recv_field
     24    MODULE PROCEDURE xios_recv_field_scalar, xios_recv_field_1d, xios_recv_field_2d, xios_recv_field_3d, &
     25            xios_recv_field_4d
     26  END INTERFACE  xios_recv_field
     27
     28  INTERFACE xios_field_is_active
     29    MODULE PROCEDURE xios_field_is_active_id, xios_field_is_active_hdl
     30  END INTERFACE xios_field_is_active
     31
     32  INTERFACE xios_set_attr
     33    MODULE PROCEDURE xios_set_fieldgroup_attr_hdl, xios_set_field_attr_hdl, xios_set_domain_attr_hdl, &
     34            xios_set_axis_attr_hdl, xios_set_file_attr_hdl
     35  END INTERFACE  xios_set_attr
     36
     37  INTERFACE xios_get_handle
     38    MODULE PROCEDURE  xios_get_context_handle, xios_get_field_handle, xios_get_fieldgroup_handle, &
     39            xios_get_domain_handle, xios_get_file_handle, xios_get_filegroup_handle
     40  END INTERFACE  xios_get_handle
     41
     42  INTERFACE xios_add_child
     43    MODULE PROCEDURE xios_fieldgroup_add_child, xios_add_fieldtofile, xios_add_file
     44  END INTERFACE  xios_add_child
     45
     46  INTERFACE xios_set_current_context
     47    MODULE PROCEDURE xios_set_current_context_hdl, xios_set_current_context_id
     48  END INTERFACE xios_set_current_context
     49
     50  INTERFACE xios_get_current_context
     51    MODULE PROCEDURE xios_get_current_context_hdl, xios_get_current_context_id
     52  END INTERFACE xios_get_current_context
     53
     54  INTERFACE xios_set_start_date
     55    MODULE PROCEDURE xios_set_start_date_date, xios_set_start_date_dur
     56  END INTERFACE xios_set_start_date
     57
     58  INTERFACE xios_set_time_origin
     59    MODULE PROCEDURE xios_set_time_origin_date, xios_set_time_origin_dur
     60  END INTERFACE xios_set_time_origin
     61
     62  INTERFACE xios_is_defined_attr
     63    MODULE PROCEDURE xios_is_defined_domain_attr_hdl
     64  END INTERFACE xios_is_defined_attr
     65
     66  TYPE xios_duration
     67    DOUBLE PRECISION :: year = 0, month = 0, day = 0, hour = 0, minute = 0, second = 0, timestep = 0
     68  END TYPE xios_duration
     69
     70  TYPE xios_date
     71    INTEGER :: year = 0, month = 0, day = 0, hour = 0, minute = 0, second = 0
     72  END TYPE xios_date
     73
     74  REAL, PARAMETER :: xios_timestep = 1.
     75  REAL, PARAMETER :: xios_second = 1.
     76
     77  TYPE xios_fieldgroup
     78  END TYPE xios_fieldgroup
     79
     80  TYPE xios_filegroup
     81  END TYPE xios_filegroup
     82
     83  TYPE xios_context
     84  END TYPE xios_context
     85
     86  TYPE xios_domain
     87  END TYPE xios_domain
     88
     89  TYPE xios_axis
     90  END TYPE xios_axis
     91
     92  TYPE xios_file
     93  END TYPE xios_file
     94
     95  TYPE xios_field
     96  END TYPE
     97
     98
     99CONTAINS
     100
     101
    103102  SUBROUTINE  xios_initialize(client_id, local_comm, return_comm)
    104    IMPLICIT NONE
    105    CHARACTER(LEN=*),INTENT(IN) :: client_id
    106    INTEGER,INTENT(IN),OPTIONAL        :: local_comm
    107    INTEGER,INTENT(OUT),OPTIONAL        :: return_comm
    108    INTEGER :: f_local_comm
    109    INTEGER :: f_return_comm
    110 
    111   END SUBROUTINE  xios_initialize 
    112 
    113 SUBROUTINE xios_define_calendar(type, timestep, start_date, time_origin, &
    114                                     day_length, month_lengths, year_length, &
    115                                     leap_year_month, leap_year_drift, leap_year_drift_offset)
    116       IMPLICIT NONE
    117       CHARACTER(len = *),              INTENT(IN) :: type
    118       TYPE(xios_duration), OPTIONAL, INTENT(IN) :: timestep
    119       TYPE(xios_date),    OPTIONAL, INTENT(IN) :: start_date
    120       TYPE(xios_date),    OPTIONAL, INTENT(IN) :: time_origin
    121       INTEGER,              OPTIONAL, INTENT(IN) :: day_length
    122       INTEGER,              OPTIONAL, INTENT(IN) :: month_lengths(:)
    123       INTEGER,              OPTIONAL, INTENT(IN) :: year_length
    124       REAL (KIND=8),        OPTIONAL, INTENT(IN) :: leap_year_drift
    125       REAL (KIND=8),        OPTIONAL, INTENT(IN) :: leap_year_drift_offset
    126       INTEGER,              OPTIONAL, INTENT(IN) :: leap_year_month
    127 
    128    END SUBROUTINE xios_define_calendar
    129    
     103    IMPLICIT NONE
     104    CHARACTER(LEN = *), INTENT(IN) :: client_id
     105    INTEGER, INTENT(IN), OPTIONAL :: local_comm
     106    INTEGER, INTENT(OUT), OPTIONAL :: return_comm
     107    INTEGER :: f_local_comm
     108    INTEGER :: f_return_comm
     109
     110  END SUBROUTINE  xios_initialize
     111
     112  SUBROUTINE xios_define_calendar(type, timestep, start_date, time_origin, &
     113          day_length, month_lengths, year_length, &
     114          leap_year_month, leap_year_drift, leap_year_drift_offset)
     115    IMPLICIT NONE
     116    CHARACTER(len = *), INTENT(IN) :: type
     117    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: timestep
     118    TYPE(xios_date), OPTIONAL, INTENT(IN) :: start_date
     119    TYPE(xios_date), OPTIONAL, INTENT(IN) :: time_origin
     120    INTEGER, OPTIONAL, INTENT(IN) :: day_length
     121    INTEGER, OPTIONAL, INTENT(IN) :: month_lengths(:)
     122    INTEGER, OPTIONAL, INTENT(IN) :: year_length
     123    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: leap_year_drift
     124    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: leap_year_drift_offset
     125    INTEGER, OPTIONAL, INTENT(IN) :: leap_year_month
     126
     127  END SUBROUTINE xios_define_calendar
     128
    130129  SUBROUTINE xios_duration_convert_to_string(dur, str)
    131130    IMPLICIT NONE
    132131    TYPE(xios_duration), INTENT(IN) :: dur
    133132    CHARACTER(len = *), INTENT(OUT) :: str
    134     str=''
     133    str = ''
    135134  END SUBROUTINE xios_duration_convert_to_string
    136135
    … …  
    142141  END FUNCTION xios_duration_convert_from_string
    143142
    144    SUBROUTINE xios_set_timestep(timestep)
    145       IMPLICIT NONE
    146       TYPE(xios_duration), INTENT(IN) :: timestep
    147    END SUBROUTINE xios_set_timestep
    148    
     143  SUBROUTINE xios_set_timestep(timestep)
     144    IMPLICIT NONE
     145    TYPE(xios_duration), INTENT(IN) :: timestep
     146  END SUBROUTINE xios_set_timestep
     147
    149148  SUBROUTINE xios_set_start_date_date(start_date)
    150       IMPLICIT NONE
    151       TYPE(xios_date), INTENT(IN) :: start_date
    152    END SUBROUTINE xios_set_start_date_date
    153 
    154    SUBROUTINE xios_set_start_date_dur(start_date)
    155       IMPLICIT NONE
    156       TYPE(xios_duration), INTENT(IN) :: start_date
    157    END SUBROUTINE xios_set_start_date_dur
    158    
    159    SUBROUTINE xios_set_time_origin_date(time_origin)
    160       IMPLICIT NONE
    161       TYPE(xios_date), INTENT(IN) :: time_origin
    162    END SUBROUTINE xios_set_time_origin_date
    163 
    164    SUBROUTINE xios_set_time_origin_dur(time_origin)
    165       IMPLICIT NONE
    166       TYPE(xios_duration), INTENT(IN) :: time_origin
    167    END SUBROUTINE xios_set_time_origin_dur
    168            
    169   SUBROUTINE xios_send_field_scalar(name,field)
    170   IMPLICIT NONE
    171     CHARACTER(LEN=*),INTENT(IN) :: name
    172     REAL,INTENT(IN) :: field
    173   END SUBROUTINE xios_send_field_scalar 
    174 
    175   SUBROUTINE xios_send_field_1d(name,field)
    176   IMPLICIT NONE
    177     CHARACTER(LEN=*),INTENT(IN) :: name
    178     REAL,INTENT(IN) :: field(:)
    179   END SUBROUTINE xios_send_field_1d 
    180 
    181   SUBROUTINE xios_send_field_2d(name,field)
    182   IMPLICIT NONE
    183     CHARACTER(LEN=*),INTENT(IN) :: name
    184     REAL,INTENT(IN) :: field(:,:)
    185   END SUBROUTINE xios_send_field_2d 
    186 
    187   SUBROUTINE xios_send_field_3d(name,field)
    188   IMPLICIT NONE
    189     CHARACTER(LEN=*),INTENT(IN) :: name
    190     REAL,INTENT(IN) :: field(:,:,:)
    191   END SUBROUTINE xios_send_field_3d 
    192 
    193   SUBROUTINE xios_send_field_4d(name,field)
    194   IMPLICIT NONE
    195     CHARACTER(LEN=*),INTENT(IN) :: name
    196     REAL,INTENT(IN) :: field(:,:,:,:)
    197   END SUBROUTINE xios_send_field_4d 
    198 
    199   SUBROUTINE xios_send_field_5d(name,field)
    200   IMPLICIT NONE
    201     CHARACTER(LEN=*),INTENT(IN) :: name
    202     REAL,INTENT(IN) :: field(:,:,:,:,:)
    203   END SUBROUTINE xios_send_field_5d 
    204 
    205 
    206   SUBROUTINE xios_recv_field_scalar(name,field)
    207   IMPLICIT NONE
    208     CHARACTER(LEN=*),INTENT(IN) :: name
    209     REAL,INTENT(OUT) :: field
    210     field=0
    211   END SUBROUTINE xios_recv_field_scalar 
    212 
    213   SUBROUTINE xios_recv_field_1d(name,field)
    214   IMPLICIT NONE
    215     CHARACTER(LEN=*),INTENT(IN) :: name
    216     REAL,INTENT(OUT) :: field(:)
    217     field=0
    218   END SUBROUTINE xios_recv_field_1d 
    219 
    220   SUBROUTINE xios_recv_field_2d(name,field)
    221   IMPLICIT NONE
    222     CHARACTER(LEN=*),INTENT(IN) :: name
    223     REAL,INTENT(OUT) :: field(:,:)
    224     field=0
    225   END SUBROUTINE xios_recv_field_2d 
    226 
    227   SUBROUTINE xios_recv_field_3d(name,field)
    228   IMPLICIT NONE
    229     CHARACTER(LEN=*),INTENT(IN) :: name
    230     REAL,INTENT(OUT) :: field(:,:,:)
    231     field=0
    232   END SUBROUTINE xios_recv_field_3d 
    233 
    234   SUBROUTINE xios_recv_field_4d(name,field)
    235   IMPLICIT NONE
    236     CHARACTER(LEN=*),INTENT(IN) :: name
    237     REAL,INTENT(OUT) :: field(:,:,:,:)
    238     field=0
    239   END SUBROUTINE xios_recv_field_4d 
     149    IMPLICIT NONE
     150    TYPE(xios_date), INTENT(IN) :: start_date
     151  END SUBROUTINE xios_set_start_date_date
     152
     153  SUBROUTINE xios_set_start_date_dur(start_date)
     154    IMPLICIT NONE
     155    TYPE(xios_duration), INTENT(IN) :: start_date
     156  END SUBROUTINE xios_set_start_date_dur
     157
     158  SUBROUTINE xios_set_time_origin_date(time_origin)
     159    IMPLICIT NONE
     160    TYPE(xios_date), INTENT(IN) :: time_origin
     161  END SUBROUTINE xios_set_time_origin_date
     162
     163  SUBROUTINE xios_set_time_origin_dur(time_origin)
     164    IMPLICIT NONE
     165    TYPE(xios_duration), INTENT(IN) :: time_origin
     166  END SUBROUTINE xios_set_time_origin_dur
     167
     168  SUBROUTINE xios_send_field_scalar(name, field)
     169    IMPLICIT NONE
     170    CHARACTER(LEN = *), INTENT(IN) :: name
     171    REAL, INTENT(IN) :: field
     172  END SUBROUTINE xios_send_field_scalar
     173
     174  SUBROUTINE xios_send_field_1d(name, field)
     175    IMPLICIT NONE
     176    CHARACTER(LEN = *), INTENT(IN) :: name
     177    REAL, INTENT(IN) :: field(:)
     178  END SUBROUTINE xios_send_field_1d
     179
     180  SUBROUTINE xios_send_field_2d(name, field)
     181    IMPLICIT NONE
     182    CHARACTER(LEN = *), INTENT(IN) :: name
     183    REAL, INTENT(IN) :: field(:, :)
     184  END SUBROUTINE xios_send_field_2d
     185
     186  SUBROUTINE xios_send_field_3d(name, field)
     187    IMPLICIT NONE
     188    CHARACTER(LEN = *), INTENT(IN) :: name
     189    REAL, INTENT(IN) :: field(:, :, :)
     190  END SUBROUTINE xios_send_field_3d
     191
     192  SUBROUTINE xios_send_field_4d(name, field)
     193    IMPLICIT NONE
     194    CHARACTER(LEN = *), INTENT(IN) :: name
     195    REAL, INTENT(IN) :: field(:, :, :, :)
     196  END SUBROUTINE xios_send_field_4d
     197
     198  SUBROUTINE xios_send_field_5d(name, field)
     199    IMPLICIT NONE
     200    CHARACTER(LEN = *), INTENT(IN) :: name
     201    REAL, INTENT(IN) :: field(:, :, :, :, :)
     202  END SUBROUTINE xios_send_field_5d
     203
     204
     205  SUBROUTINE xios_recv_field_scalar(name, field)
     206    IMPLICIT NONE
     207    CHARACTER(LEN = *), INTENT(IN) :: name
     208    REAL, INTENT(OUT) :: field
     209    field = 0
     210  END SUBROUTINE xios_recv_field_scalar
     211
     212  SUBROUTINE xios_recv_field_1d(name, field)
     213    IMPLICIT NONE
     214    CHARACTER(LEN = *), INTENT(IN) :: name
     215    REAL, INTENT(OUT) :: field(:)
     216    field = 0
     217  END SUBROUTINE xios_recv_field_1d
     218
     219  SUBROUTINE xios_recv_field_2d(name, field)
     220    IMPLICIT NONE
     221    CHARACTER(LEN = *), INTENT(IN) :: name
     222    REAL, INTENT(OUT) :: field(:, :)
     223    field = 0
     224  END SUBROUTINE xios_recv_field_2d
     225
     226  SUBROUTINE xios_recv_field_3d(name, field)
     227    IMPLICIT NONE
     228    CHARACTER(LEN = *), INTENT(IN) :: name
     229    REAL, INTENT(OUT) :: field(:, :, :)
     230    field = 0
     231  END SUBROUTINE xios_recv_field_3d
     232
     233  SUBROUTINE xios_recv_field_4d(name, field)
     234    IMPLICIT NONE
     235    CHARACTER(LEN = *), INTENT(IN) :: name
     236    REAL, INTENT(OUT) :: field(:, :, :, :)
     237    field = 0
     238  END SUBROUTINE xios_recv_field_4d
    240239
    241240
    242241  FUNCTION xios_is_active_field(field_id)
    243   IMPLICIT NONE
    244    LOGICAL :: xios_is_active_field
    245    CHARACTER(LEN=*) :: field_id
     242    IMPLICIT NONE
     243    LOGICAL :: xios_is_active_field
     244    CHARACTER(LEN = *) :: field_id
    246245    xios_is_active_field = .TRUE.
    247246  END FUNCTION xios_is_active_field
    … …  
    249248  LOGICAL FUNCTION xios_is_valid_field(idt)
    250249    IMPLICIT NONE
    251     CHARACTER(len  = *)    , INTENT(IN) :: idt
     250    CHARACTER(len = *), INTENT(IN) :: idt
    252251    xios_is_valid_field = .FALSE.
    253252  END FUNCTION  xios_is_valid_field
    … …  
    255254  LOGICAL FUNCTION xios_is_valid_file(idt)
    256255    IMPLICIT NONE
    257     CHARACTER(len  = *)    , INTENT(IN) :: idt
     256    CHARACTER(len = *), INTENT(IN) :: idt
    258257    xios_is_valid_file = .FALSE.
    259258  END FUNCTION  xios_is_valid_file
    … …  
    261260  LOGICAL FUNCTION xios_is_valid_axis(idt)
    262261    IMPLICIT NONE
    263     CHARACTER(len  = *)    , INTENT(IN) :: idt
     262    CHARACTER(len = *), INTENT(IN) :: idt
    264263    xios_is_valid_axis = .FALSE.
    265264  END FUNCTION  xios_is_valid_axis
    … …  
    267266  LOGICAL FUNCTION xios_is_valid_domain(idt)
    268267    IMPLICIT NONE
    269     CHARACTER(len  = *)    , INTENT(IN) :: idt
     268    CHARACTER(len = *), INTENT(IN) :: idt
    270269    xios_is_valid_domain = .FALSE.
    271270  END FUNCTION  xios_is_valid_domain
    272271
    273272
    274    SUBROUTINE  xios_context_initialize(context_id,comm)
    275    IMPLICIT NONE
    276    CHARACTER(LEN=*),INTENT(IN)  :: context_id
    277    INTEGER, INTENT(IN)          :: comm
    278 
    279    END SUBROUTINE  xios_context_initialize
    280 
    281 
    282    SUBROUTINE  xios_finalize
    283    IMPLICIT NONE
    284 
    285    END SUBROUTINE  xios_finalize
    286 
    287 
    288    SUBROUTINE  xios_oasis_enddef
    289    IMPLICIT NONE
    290 
    291    END SUBROUTINE  xios_oasis_enddef
    292 
    293 
    294    SUBROUTINE xios_close_context_definition
    295    IMPLICIT NONE
    296 
    297    END SUBROUTINE xios_close_context_definition
    298 
    299 
    300    SUBROUTINE xios_set_current_context_hdl(context, withswap)
    301       IMPLICIT NONE
    302       TYPE(xios_context)          , INTENT(IN) :: context
    303       LOGICAL                     , OPTIONAL, INTENT(IN) :: withswap
    304    END SUBROUTINE xios_set_current_context_hdl
    305    
    306    SUBROUTINE xios_set_current_context_id(idt)
    307       IMPLICIT NONE
    308 
    309       CHARACTER(len = *) , INTENT(IN) :: idt
    310       LOGICAL           :: withswap
    311     END SUBROUTINE xios_set_current_context_id
    312    
    313 
    314    SUBROUTINE xios_get_current_context_hdl(context)
    315       IMPLICIT NONE
    316       TYPE(xios_context), INTENT(OUT) :: context
    317    END SUBROUTINE xios_get_current_context_hdl
    318 
    319    SUBROUTINE xios_get_current_context_id(idt)
    320       IMPLICIT NONE
    321       CHARACTER(len = *) , INTENT(OUT) :: idt
    322       TYPE(xios_context) :: context
    323    END SUBROUTINE xios_get_current_context_id
    324 
    325    SUBROUTINE xios_context_finalize()
    326    IMPLICIT NONE
    327 
    328    END SUBROUTINE xios_context_finalize
    329 
    330 
    331    SUBROUTINE xios_solve_inheritance()
    332    IMPLICIT NONE
    333 
    334    END SUBROUTINE xios_solve_inheritance
    335 
    336 
    337 
    338 
    339  
     273  SUBROUTINE  xios_context_initialize(context_id, comm)
     274    IMPLICIT NONE
     275    CHARACTER(LEN = *), INTENT(IN) :: context_id
     276    INTEGER, INTENT(IN) :: comm
     277
     278  END SUBROUTINE  xios_context_initialize
     279
     280
     281  SUBROUTINE  xios_finalize
     282    IMPLICIT NONE
     283
     284  END SUBROUTINE  xios_finalize
     285
     286
     287  SUBROUTINE  xios_oasis_enddef
     288    IMPLICIT NONE
     289
     290  END SUBROUTINE  xios_oasis_enddef
     291
     292
     293  SUBROUTINE xios_close_context_definition
     294    IMPLICIT NONE
     295
     296  END SUBROUTINE xios_close_context_definition
     297
     298
     299  SUBROUTINE xios_set_current_context_hdl(context, withswap)
     300    IMPLICIT NONE
     301    TYPE(xios_context), INTENT(IN) :: context
     302    LOGICAL, OPTIONAL, INTENT(IN) :: withswap
     303  END SUBROUTINE xios_set_current_context_hdl
     304
     305  SUBROUTINE xios_set_current_context_id(idt)
     306    IMPLICIT NONE
     307
     308    CHARACTER(len = *), INTENT(IN) :: idt
     309    LOGICAL :: withswap
     310  END SUBROUTINE xios_set_current_context_id
     311
     312
     313  SUBROUTINE xios_get_current_context_hdl(context)
     314    IMPLICIT NONE
     315    TYPE(xios_context), INTENT(OUT) :: context
     316  END SUBROUTINE xios_get_current_context_hdl
     317
     318  SUBROUTINE xios_get_current_context_id(idt)
     319    IMPLICIT NONE
     320    CHARACTER(len = *), INTENT(OUT) :: idt
     321    TYPE(xios_context) :: context
     322  END SUBROUTINE xios_get_current_context_id
     323
     324  SUBROUTINE xios_context_finalize()
     325    IMPLICIT NONE
     326
     327  END SUBROUTINE xios_context_finalize
     328
     329
     330  SUBROUTINE xios_solve_inheritance()
     331    IMPLICIT NONE
     332
     333  END SUBROUTINE xios_solve_inheritance
     334
     335
    340336  SUBROUTINE xios_update_calendar(step)
    341   IMPLICIT NONE
    342    INTEGER, INTENT(IN):: step 
     337    IMPLICIT NONE
     338    INTEGER, INTENT(IN) :: step
    343339  END SUBROUTINE xios_update_calendar
    344340
    345   SUBROUTINE xios_set_filegroup_attr(name,enabled)
    346     CHARACTER(LEN=*) :: name
    347     LOGICAL,OPTIONAL          :: enabled
     341  SUBROUTINE xios_set_filegroup_attr(name, enabled)
     342    CHARACTER(LEN = *) :: name
     343    LOGICAL, OPTIONAL :: enabled
    348344  END SUBROUTINE xios_set_filegroup_attr
    349345
    350   SUBROUTINE xios_get_axis_attr(name,n_glo,value)
    351     CHARACTER(LEN=*) :: name
    352     INTEGER,OPTIONAL          :: n_glo
    353     REAL,OPTIONAL            :: value(:)
     346  SUBROUTINE xios_get_axis_attr(name, n_glo, value)
     347    CHARACTER(LEN = *) :: name
     348    INTEGER, OPTIONAL :: n_glo
     349    REAL, OPTIONAL :: value(:)
    354350  END SUBROUTINE xios_get_axis_attr
    355351
    356    SUBROUTINE xios_get_context_handle(idt,ret)
    357     IMPLICIT NONE
    358     CHARACTER(len = *)  , INTENT(IN)  :: idt
    359     TYPE(xios_context), INTENT(OUT):: ret
    360     TYPE(xios_context)             :: nothing
    361      
    362       ret=nothing
    363    END SUBROUTINE xios_get_context_handle
    364 
    365    SUBROUTINE xios_get_domain_handle(idt,ret)
    366       IMPLICIT NONE
    367       CHARACTER(len = *) , INTENT(IN) :: idt     
    368       TYPE(xios_domain), INTENT(OUT):: ret
    369       TYPE(xios_domain)             :: hdl
    370       ret=hdl
    371    END SUBROUTINE xios_get_domain_handle   
    372 
    373    SUBROUTINE xios_get_field_handle(idt,ret)
    374       IMPLICIT NONE
    375       CHARACTER(len = *) , INTENT(IN) :: idt     
    376       TYPE(xios_field), INTENT(OUT):: ret
    377       TYPE(xios_field)             :: hdl
    378       ret=hdl
    379    END SUBROUTINE xios_get_field_handle   
    380 
    381    SUBROUTINE xios_get_fieldgroup_handle(idt,ret)
    382       IMPLICIT NONE
    383       CHARACTER(len = *) , INTENT(IN) :: idt     
    384       TYPE(xios_fieldgroup), INTENT(OUT):: ret
    385       TYPE(xios_fieldgroup)             :: hdl
    386       ret=hdl
    387    END SUBROUTINE xios_get_fieldgroup_handle   
    388 
    389    SUBROUTINE xios_get_file_handle(idt,ret)
    390       IMPLICIT NONE
    391       CHARACTER(len = *) , INTENT(IN) :: idt     
    392       TYPE(xios_file), INTENT(OUT):: ret
    393       TYPE(xios_file)             :: hdl
    394       ret=hdl
    395    END SUBROUTINE xios_get_file_handle   
    396 
    397    SUBROUTINE xios_get_filegroup_handle(idt,ret)
    398       IMPLICIT NONE
    399       CHARACTER(len = *) , INTENT(IN) :: idt     
    400       TYPE(xios_filegroup), INTENT(OUT):: ret
    401       TYPE(xios_filegroup)             :: hdl
    402       ret=hdl
    403    END SUBROUTINE xios_get_filegroup_handle   
    404 
     352  SUBROUTINE xios_get_context_handle(idt, ret)
     353    IMPLICIT NONE
     354    CHARACTER(len = *), INTENT(IN) :: idt
     355    TYPE(xios_context), INTENT(OUT) :: ret
     356    TYPE(xios_context) :: nothing
     357
     358    ret = nothing
     359  END SUBROUTINE xios_get_context_handle
     360
     361  SUBROUTINE xios_get_domain_handle(idt, ret)
     362    IMPLICIT NONE
     363    CHARACTER(len = *), INTENT(IN) :: idt
     364    TYPE(xios_domain), INTENT(OUT) :: ret
     365    TYPE(xios_domain) :: hdl
     366    ret = hdl
     367  END SUBROUTINE xios_get_domain_handle
     368
     369  SUBROUTINE xios_get_field_handle(idt, ret)
     370    IMPLICIT NONE
     371    CHARACTER(len = *), INTENT(IN) :: idt
     372    TYPE(xios_field), INTENT(OUT) :: ret
     373    TYPE(xios_field) :: hdl
     374    ret = hdl
     375  END SUBROUTINE xios_get_field_handle
     376
     377  SUBROUTINE xios_get_fieldgroup_handle(idt, ret)
     378    IMPLICIT NONE
     379    CHARACTER(len = *), INTENT(IN) :: idt
     380    TYPE(xios_fieldgroup), INTENT(OUT) :: ret
     381    TYPE(xios_fieldgroup) :: hdl
     382    ret = hdl
     383  END SUBROUTINE xios_get_fieldgroup_handle
     384
     385  SUBROUTINE xios_get_file_handle(idt, ret)
     386    IMPLICIT NONE
     387    CHARACTER(len = *), INTENT(IN) :: idt
     388    TYPE(xios_file), INTENT(OUT) :: ret
     389    TYPE(xios_file) :: hdl
     390    ret = hdl
     391  END SUBROUTINE xios_get_file_handle
     392
     393  SUBROUTINE xios_get_filegroup_handle(idt, ret)
     394    IMPLICIT NONE
     395    CHARACTER(len = *), INTENT(IN) :: idt
     396    TYPE(xios_filegroup), INTENT(OUT) :: ret
     397    TYPE(xios_filegroup) :: hdl
     398    ret = hdl
     399  END SUBROUTINE xios_get_filegroup_handle
    405400
    406401
    407402  SUBROUTINE xios_fieldgroup_add_child(fieldgroup_hdl, field_hdl, id)
    408     TYPE(xios_fieldgroup)     :: fieldgroup_hdl
    409     TYPE(xios_field)          :: field_hdl
    410     CHARACTER(LEN=*),OPTIONAL :: id
     403    TYPE(xios_fieldgroup) :: fieldgroup_hdl
     404    TYPE(xios_field) :: field_hdl
     405    CHARACTER(LEN = *), OPTIONAL :: id
    411406  END SUBROUTINE xios_fieldgroup_add_child
    412407
    413408  SUBROUTINE xios_add_file(parent_hdl, child_hdl, child_id)
    414       TYPE(xios_filegroup)      , INTENT(IN) :: parent_hdl
    415       TYPE(xios_file)           , INTENT(OUT):: child_hdl
    416       CHARACTER(len = *), OPTIONAL, INTENT(IN) :: child_id
    417       TYPE(xios_file) :: hdl
    418       child_hdl = hdl
     409    TYPE(xios_filegroup), INTENT(IN) :: parent_hdl
     410    TYPE(xios_file), INTENT(OUT) :: child_hdl
     411    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: child_id
     412    TYPE(xios_file) :: hdl
     413    child_hdl = hdl
    419414  END SUBROUTINE xios_add_file
    420415
    421416  SUBROUTINE xios_add_field(parent_hdl, child_hdl, child_id)
    422       TYPE(xios_fieldgroup)      , INTENT(IN) :: parent_hdl
    423       TYPE(xios_field)           , INTENT(OUT):: child_hdl
    424       CHARACTER(len = *), OPTIONAL, INTENT(IN)  :: child_id
    425       TYPE(xios_field) :: hdl
    426       child_hdl = hdl
    427   END SUBROUTINE xios_add_field
    428  
    429   SUBROUTINE xios_add_fieldtofile(parent_hdl, child_hdl, child_id)
    430     TYPE(xios_file)            , INTENT(IN) :: parent_hdl
    431     TYPE(xios_field)           , INTENT(OUT):: child_hdl
    432     CHARACTER(len = *), OPTIONAL , INTENT(IN) :: child_id
     417    TYPE(xios_fieldgroup), INTENT(IN) :: parent_hdl
     418    TYPE(xios_field), INTENT(OUT) :: child_hdl
     419    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: child_id
    433420    TYPE(xios_field) :: hdl
    434421    child_hdl = hdl
     422  END SUBROUTINE xios_add_field
     423
     424  SUBROUTINE xios_add_fieldtofile(parent_hdl, child_hdl, child_id)
     425    TYPE(xios_file), INTENT(IN) :: parent_hdl
     426    TYPE(xios_field), INTENT(OUT) :: child_hdl
     427    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: child_id
     428    TYPE(xios_field) :: hdl
     429    child_hdl = hdl
    435430
    436431  END SUBROUTINE xios_add_fieldtofile
    437    
     432
    438433  LOGICAL FUNCTION xios_field_is_active_id(field_id, at_current_timestep_arg)
    439       IMPLICIT NONE
    440       CHARACTER(len  = *) , INTENT(IN) :: field_id
    441       LOGICAL, OPTIONAL   , INTENT(IN) :: at_current_timestep_arg
    442 
    443      xios_field_is_active_id=.FALSE.
    444    END FUNCTION xios_field_is_active_id
    445 
    446    LOGICAL FUNCTION xios_field_is_active_hdl(field_hdl, at_current_timestep_arg)
    447       IMPLICIT NONE
    448       TYPE(xios_field) , INTENT(IN) :: field_hdl
    449       LOGICAL, OPTIONAL  , INTENT(IN) :: at_current_timestep_arg
    450 
    451      xios_field_is_active_hdl = .FALSE.
    452    END FUNCTION xios_field_is_active_hdl
    453    
    454 
    455   SUBROUTINE  xios_set_generate_rectilinear_domain_attr(id, bounds_lon_start, bounds_lon_end,  bounds_lat_start, bounds_lat_end)
    456     CHARACTER(LEN=*) :: id
     434    IMPLICIT NONE
     435    CHARACTER(len = *), INTENT(IN) :: field_id
     436    LOGICAL, OPTIONAL, INTENT(IN) :: at_current_timestep_arg
     437
     438    xios_field_is_active_id = .FALSE.
     439  END FUNCTION xios_field_is_active_id
     440
     441  LOGICAL FUNCTION xios_field_is_active_hdl(field_hdl, at_current_timestep_arg)
     442    IMPLICIT NONE
     443    TYPE(xios_field), INTENT(IN) :: field_hdl
     444    LOGICAL, OPTIONAL, INTENT(IN) :: at_current_timestep_arg
     445
     446    xios_field_is_active_hdl = .FALSE.
     447  END FUNCTION xios_field_is_active_hdl
     448
     449
     450  SUBROUTINE  xios_set_generate_rectilinear_domain_attr(id, bounds_lon_start, bounds_lon_end, bounds_lat_start, bounds_lat_end)
     451    CHARACTER(LEN = *) :: id
    457452    REAL, OPTIONAL :: bounds_lon_start
    458453    REAL, OPTIONAL :: bounds_lon_end
    459454    REAL, OPTIONAL :: bounds_lat_start
    460455    REAL, OPTIONAL :: bounds_lat_end
    461   END SUBROUTINE  xios_set_generate_rectilinear_domain_attr   
     456  END SUBROUTINE  xios_set_generate_rectilinear_domain_attr
    462457
    463458  SUBROUTINE xios_set_domain_attr  &
    464     ( domain_id, area, bounds_lat_1d, bounds_lat_2d, bounds_lat_name, bounds_lon_1d, bounds_lon_2d  &
    465     , bounds_lon_name, comment, data_dim, data_i_index, data_ibegin, data_j_index, data_jbegin, data_ni  &
    466     , data_nj, dim_i_name, dim_j_name, domain_ref, i_index, ibegin, j_index, jbegin, lat_name, latvalue_1d  &
    467     , latvalue_2d, lon_name, long_name, lonvalue_1d, lonvalue_2d, mask_1d, mask_2d, name, ni, ni_glo  &
    468     , nj, nj_glo, nvertex, prec, radius, standard_name, type )
    469 
    470     IMPLICIT NONE
    471       TYPE(xios_domain) :: domain_hdl
    472       CHARACTER(LEN=*), INTENT(IN) ::domain_id
    473       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: area(:,:)
    474       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: bounds_lat_1d(:,:)
    475       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: bounds_lat_2d(:,:,:)
    476       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: bounds_lat_name
    477       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: bounds_lon_1d(:,:)
    478       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: bounds_lon_2d(:,:,:)
    479       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: bounds_lon_name
    480       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: comment
    481       INTEGER  , OPTIONAL, INTENT(IN) :: data_dim
    482       INTEGER  , OPTIONAL, INTENT(IN) :: data_i_index(:)
    483       INTEGER  , OPTIONAL, INTENT(IN) :: data_ibegin
    484       INTEGER  , OPTIONAL, INTENT(IN) :: data_j_index(:)
    485       INTEGER  , OPTIONAL, INTENT(IN) :: data_jbegin
    486       INTEGER  , OPTIONAL, INTENT(IN) :: data_ni
    487       INTEGER  , OPTIONAL, INTENT(IN) :: data_nj
    488       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: dim_i_name
    489       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: dim_j_name
    490       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: domain_ref
    491       INTEGER  , OPTIONAL, INTENT(IN) :: i_index(:)
    492       INTEGER  , OPTIONAL, INTENT(IN) :: ibegin
    493       INTEGER  , OPTIONAL, INTENT(IN) :: j_index(:)
    494       INTEGER  , OPTIONAL, INTENT(IN) :: jbegin
    495       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: lat_name
    496       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: latvalue_1d(:)
    497       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: latvalue_2d(:,:)
    498       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: lon_name
    499       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: long_name
    500       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: lonvalue_1d(:)
    501       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: lonvalue_2d(:,:)
    502       LOGICAL  , OPTIONAL, INTENT(IN) :: mask_1d(:)
    503       LOGICAL  , OPTIONAL, INTENT(IN) :: mask_2d(:,:)
    504       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name
    505       INTEGER  , OPTIONAL, INTENT(IN) :: ni
    506       INTEGER  , OPTIONAL, INTENT(IN) :: ni_glo
    507       INTEGER  , OPTIONAL, INTENT(IN) :: nj
    508       INTEGER  , OPTIONAL, INTENT(IN) :: nj_glo
    509       INTEGER  , OPTIONAL, INTENT(IN) :: nvertex
    510       INTEGER  , OPTIONAL, INTENT(IN) :: prec
    511       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: radius
    512       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: standard_name
    513       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: type
    514 
    515   END SUBROUTINE xios_set_domain_attr 
     459          (domain_id, area, bounds_lat_1d, bounds_lat_2d, bounds_lat_name, bounds_lon_1d, bounds_lon_2d  &
     460          , bounds_lon_name, comment, data_dim, data_i_index, data_ibegin, data_j_index, data_jbegin, data_ni  &
     461          , data_nj, dim_i_name, dim_j_name, domain_ref, i_index, ibegin, j_index, jbegin, lat_name, latvalue_1d  &
     462          , latvalue_2d, lon_name, long_name, lonvalue_1d, lonvalue_2d, mask_1d, mask_2d, name, ni, ni_glo  &
     463          , nj, nj_glo, nvertex, prec, radius, standard_name, type)
     464
     465    IMPLICIT NONE
     466    TYPE(xios_domain) :: domain_hdl
     467    CHARACTER(LEN = *), INTENT(IN) :: domain_id
     468    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: area(:, :)
     469    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: bounds_lat_1d(:, :)
     470    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: bounds_lat_2d(:, :, :)
     471    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: bounds_lat_name
     472    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: bounds_lon_1d(:, :)
     473    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: bounds_lon_2d(:, :, :)
     474    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: bounds_lon_name
     475    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: comment
     476    INTEGER, OPTIONAL, INTENT(IN) :: data_dim
     477    INTEGER, OPTIONAL, INTENT(IN) :: data_i_index(:)
     478    INTEGER, OPTIONAL, INTENT(IN) :: data_ibegin
     479    INTEGER, OPTIONAL, INTENT(IN) :: data_j_index(:)
     480    INTEGER, OPTIONAL, INTENT(IN) :: data_jbegin
     481    INTEGER, OPTIONAL, INTENT(IN) :: data_ni
     482    INTEGER, OPTIONAL, INTENT(IN) :: data_nj
     483    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: dim_i_name
     484    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: dim_j_name
     485    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: domain_ref
     486    INTEGER, OPTIONAL, INTENT(IN) :: i_index(:)
     487    INTEGER, OPTIONAL, INTENT(IN) :: ibegin
     488    INTEGER, OPTIONAL, INTENT(IN) :: j_index(:)
     489    INTEGER, OPTIONAL, INTENT(IN) :: jbegin
     490    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: lat_name
     491    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: latvalue_1d(:)
     492    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: latvalue_2d(:, :)
     493    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: lon_name
     494    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: long_name
     495    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: lonvalue_1d(:)
     496    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: lonvalue_2d(:, :)
     497    LOGICAL, OPTIONAL, INTENT(IN) :: mask_1d(:)
     498    LOGICAL, OPTIONAL, INTENT(IN) :: mask_2d(:, :)
     499    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name
     500    INTEGER, OPTIONAL, INTENT(IN) :: ni
     501    INTEGER, OPTIONAL, INTENT(IN) :: ni_glo
     502    INTEGER, OPTIONAL, INTENT(IN) :: nj
     503    INTEGER, OPTIONAL, INTENT(IN) :: nj_glo
     504    INTEGER, OPTIONAL, INTENT(IN) :: nvertex
     505    INTEGER, OPTIONAL, INTENT(IN) :: prec
     506    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: radius
     507    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: standard_name
     508    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: type
     509
     510  END SUBROUTINE xios_set_domain_attr
    516511
    517512  SUBROUTINE xios_set_domain_attr_hdl  &
    518     ( domain_hdl, area, bounds_lat_1d, bounds_lat_2d, bounds_lat_name, bounds_lon_1d, bounds_lon_2d  &
    519     , bounds_lon_name, comment, data_dim, data_i_index, data_ibegin, data_j_index, data_jbegin, data_ni  &
    520     , data_nj, dim_i_name, dim_j_name, domain_ref, i_index, ibegin, j_index, jbegin, lat_name, latvalue_1d  &
    521     , latvalue_2d, lon_name, long_name, lonvalue_1d, lonvalue_2d, mask_1d, mask_2d, name, ni, ni_glo  &
    522     , nj, nj_glo, nvertex, prec, radius, standard_name, type )
    523 
    524     IMPLICIT NONE
    525       TYPE(xios_domain) , INTENT(IN) :: domain_hdl
    526       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: area(:,:)
    527       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: bounds_lat_1d(:,:)
    528       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: bounds_lat_2d(:,:,:)
    529       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: bounds_lat_name
    530       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: bounds_lon_1d(:,:)
    531       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: bounds_lon_2d(:,:,:)
    532       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: bounds_lon_name
    533       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: comment
    534       INTEGER  , OPTIONAL, INTENT(IN) :: data_dim
    535       INTEGER  , OPTIONAL, INTENT(IN) :: data_i_index(:)
    536       INTEGER  , OPTIONAL, INTENT(IN) :: data_ibegin
    537       INTEGER  , OPTIONAL, INTENT(IN) :: data_j_index(:)
    538       INTEGER  , OPTIONAL, INTENT(IN) :: data_jbegin
    539       INTEGER  , OPTIONAL, INTENT(IN) :: data_ni
    540       INTEGER  , OPTIONAL, INTENT(IN) :: data_nj
    541       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: dim_i_name
    542       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: dim_j_name
    543       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: domain_ref
    544       INTEGER  , OPTIONAL, INTENT(IN) :: i_index(:)
    545       INTEGER  , OPTIONAL, INTENT(IN) :: ibegin
    546       INTEGER  , OPTIONAL, INTENT(IN) :: j_index(:)
    547       INTEGER  , OPTIONAL, INTENT(IN) :: jbegin
    548       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: lat_name
    549       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: latvalue_1d(:)
    550       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: latvalue_2d(:,:)
    551       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: lon_name
    552       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: long_name
    553       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: lonvalue_1d(:)
    554       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: lonvalue_2d(:,:)
    555       LOGICAL  , OPTIONAL, INTENT(IN) :: mask_1d(:)
    556       LOGICAL  , OPTIONAL, INTENT(IN) :: mask_2d(:,:)
    557       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name
    558       INTEGER  , OPTIONAL, INTENT(IN) :: ni
    559       INTEGER  , OPTIONAL, INTENT(IN) :: ni_glo
    560       INTEGER  , OPTIONAL, INTENT(IN) :: nj
    561       INTEGER  , OPTIONAL, INTENT(IN) :: nj_glo
    562       INTEGER  , OPTIONAL, INTENT(IN) :: nvertex
    563       INTEGER  , OPTIONAL, INTENT(IN) :: prec
    564       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: radius
    565       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: standard_name
    566       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: type
    567  
     513          (domain_hdl, area, bounds_lat_1d, bounds_lat_2d, bounds_lat_name, bounds_lon_1d, bounds_lon_2d  &
     514          , bounds_lon_name, comment, data_dim, data_i_index, data_ibegin, data_j_index, data_jbegin, data_ni  &
     515          , data_nj, dim_i_name, dim_j_name, domain_ref, i_index, ibegin, j_index, jbegin, lat_name, latvalue_1d  &
     516          , latvalue_2d, lon_name, long_name, lonvalue_1d, lonvalue_2d, mask_1d, mask_2d, name, ni, ni_glo  &
     517          , nj, nj_glo, nvertex, prec, radius, standard_name, type)
     518
     519    IMPLICIT NONE
     520    TYPE(xios_domain), INTENT(IN) :: domain_hdl
     521    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: area(:, :)
     522    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: bounds_lat_1d(:, :)
     523    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: bounds_lat_2d(:, :, :)
     524    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: bounds_lat_name
     525    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: bounds_lon_1d(:, :)
     526    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: bounds_lon_2d(:, :, :)
     527    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: bounds_lon_name
     528    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: comment
     529    INTEGER, OPTIONAL, INTENT(IN) :: data_dim
     530    INTEGER, OPTIONAL, INTENT(IN) :: data_i_index(:)
     531    INTEGER, OPTIONAL, INTENT(IN) :: data_ibegin
     532    INTEGER, OPTIONAL, INTENT(IN) :: data_j_index(:)
     533    INTEGER, OPTIONAL, INTENT(IN) :: data_jbegin
     534    INTEGER, OPTIONAL, INTENT(IN) :: data_ni
     535    INTEGER, OPTIONAL, INTENT(IN) :: data_nj
     536    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: dim_i_name
     537    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: dim_j_name
     538    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: domain_ref
     539    INTEGER, OPTIONAL, INTENT(IN) :: i_index(:)
     540    INTEGER, OPTIONAL, INTENT(IN) :: ibegin
     541    INTEGER, OPTIONAL, INTENT(IN) :: j_index(:)
     542    INTEGER, OPTIONAL, INTENT(IN) :: jbegin
     543    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: lat_name
     544    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: latvalue_1d(:)
     545    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: latvalue_2d(:, :)
     546    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: lon_name
     547    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: long_name
     548    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: lonvalue_1d(:)
     549    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: lonvalue_2d(:, :)
     550    LOGICAL, OPTIONAL, INTENT(IN) :: mask_1d(:)
     551    LOGICAL, OPTIONAL, INTENT(IN) :: mask_2d(:, :)
     552    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name
     553    INTEGER, OPTIONAL, INTENT(IN) :: ni
     554    INTEGER, OPTIONAL, INTENT(IN) :: ni_glo
     555    INTEGER, OPTIONAL, INTENT(IN) :: nj
     556    INTEGER, OPTIONAL, INTENT(IN) :: nj_glo
     557    INTEGER, OPTIONAL, INTENT(IN) :: nvertex
     558    INTEGER, OPTIONAL, INTENT(IN) :: prec
     559    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: radius
     560    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: standard_name
     561    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: type
     562
    568563  END SUBROUTINE xios_set_domain_attr_hdl
    569564
    570565
    571 
    572566  SUBROUTINE xios_set_axis_attr  &
    573     ( axis_id, axis_ref, axis_type, begin, bounds, bounds_name, comment, data_begin, data_index  &
    574     , data_n, dim_name, formula, formula_bounds, formula_term, formula_term_bounds, index, label  &
    575     , long_name, mask, n, n_distributed_partition, n_glo, name, positive, prec, standard_name, unit  &
    576     , value )
    577 
    578     IMPLICIT NONE
    579       TYPE(xios_axis) :: axis_hdl
    580       CHARACTER(LEN=*), INTENT(IN) ::axis_id
    581       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: axis_ref
    582       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: axis_type
    583       INTEGER  , OPTIONAL, INTENT(IN) :: begin
    584       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: bounds(:,:)
    585       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: bounds_name
    586       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: comment
    587       INTEGER  , OPTIONAL, INTENT(IN) :: data_begin
    588       INTEGER  , OPTIONAL, INTENT(IN) :: data_index(:)
    589       INTEGER  , OPTIONAL, INTENT(IN) :: data_n
    590       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: dim_name
    591       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: formula
    592       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: formula_bounds
    593       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: formula_term
    594       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: formula_term_bounds
    595       INTEGER  , OPTIONAL, INTENT(IN) :: index(:)
    596       CHARACTER(len=*) , OPTIONAL, INTENT(IN) :: label(:)
    597       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: long_name
    598       LOGICAL  , OPTIONAL, INTENT(IN) :: mask(:)
    599       INTEGER  , OPTIONAL, INTENT(IN) :: n
    600       INTEGER  , OPTIONAL, INTENT(IN) :: n_distributed_partition
    601       INTEGER  , OPTIONAL, INTENT(IN) :: n_glo
    602       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name
    603       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: positive
    604       INTEGER  , OPTIONAL, INTENT(IN) :: prec
    605       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: standard_name
    606       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: unit
    607       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: value(:)
     567          (axis_id, axis_ref, axis_type, begin, bounds, bounds_name, comment, data_begin, data_index  &
     568          , data_n, dim_name, formula, formula_bounds, formula_term, formula_term_bounds, index, label  &
     569          , long_name, mask, n, n_distributed_partition, n_glo, name, positive, prec, standard_name, unit  &
     570          , value)
     571
     572    IMPLICIT NONE
     573    TYPE(xios_axis) :: axis_hdl
     574    CHARACTER(LEN = *), INTENT(IN) :: axis_id
     575    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: axis_ref
     576    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: axis_type
     577    INTEGER, OPTIONAL, INTENT(IN) :: begin
     578    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: bounds(:, :)
     579    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: bounds_name
     580    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: comment
     581    INTEGER, OPTIONAL, INTENT(IN) :: data_begin
     582    INTEGER, OPTIONAL, INTENT(IN) :: data_index(:)
     583    INTEGER, OPTIONAL, INTENT(IN) :: data_n
     584    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: dim_name
     585    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: formula
     586    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: formula_bounds
     587    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: formula_term
     588    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: formula_term_bounds
     589    INTEGER, OPTIONAL, INTENT(IN) :: index(:)
     590    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: label(:)
     591    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: long_name
     592    LOGICAL, OPTIONAL, INTENT(IN) :: mask(:)
     593    INTEGER, OPTIONAL, INTENT(IN) :: n
     594    INTEGER, OPTIONAL, INTENT(IN) :: n_distributed_partition
     595    INTEGER, OPTIONAL, INTENT(IN) :: n_glo
     596    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name
     597    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: positive
     598    INTEGER, OPTIONAL, INTENT(IN) :: prec
     599    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: standard_name
     600    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: unit
     601    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: value(:)
    608602
    609603  END SUBROUTINE xios_set_axis_attr
    610604
    611605  SUBROUTINE xios_set_axis_attr_hdl  &
    612     ( axis_hdl, axis_ref, axis_type, begin, bounds, bounds_name, comment, data_begin, data_index  &
    613     , data_n, dim_name, formula, formula_bounds, formula_term, formula_term_bounds, index, label  &
    614     , long_name, mask, n, n_distributed_partition, n_glo, name, positive, prec, standard_name, unit  &
    615     , value )
    616 
    617     IMPLICIT NONE
    618       TYPE(xios_axis) , INTENT(IN) :: axis_hdl
    619       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: axis_ref
    620       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: axis_type
    621       INTEGER  , OPTIONAL, INTENT(IN) :: begin
    622       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: bounds(:,:)
    623       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: bounds_name
    624       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: comment
    625       INTEGER  , OPTIONAL, INTENT(IN) :: data_begin
    626       INTEGER  , OPTIONAL, INTENT(IN) :: data_index(:)
    627       INTEGER  , OPTIONAL, INTENT(IN) :: data_n
    628       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: dim_name
    629       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: formula
    630       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: formula_bounds
    631       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: formula_term
    632       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: formula_term_bounds
    633       INTEGER  , OPTIONAL, INTENT(IN) :: index(:)
    634       CHARACTER(len=*) , OPTIONAL, INTENT(IN) :: label(:)
    635       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: long_name
    636       LOGICAL  , OPTIONAL, INTENT(IN) :: mask(:)
    637       INTEGER  , OPTIONAL, INTENT(IN) :: n
    638       INTEGER  , OPTIONAL, INTENT(IN) :: n_distributed_partition
    639       INTEGER  , OPTIONAL, INTENT(IN) :: n_glo
    640       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name
    641       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: positive
    642       INTEGER  , OPTIONAL, INTENT(IN) :: prec
    643       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: standard_name
    644       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: unit
    645       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: value(:)
     606          (axis_hdl, axis_ref, axis_type, begin, bounds, bounds_name, comment, data_begin, data_index  &
     607          , data_n, dim_name, formula, formula_bounds, formula_term, formula_term_bounds, index, label  &
     608          , long_name, mask, n, n_distributed_partition, n_glo, name, positive, prec, standard_name, unit  &
     609          , value)
     610
     611    IMPLICIT NONE
     612    TYPE(xios_axis), INTENT(IN) :: axis_hdl
     613    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: axis_ref
     614    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: axis_type
     615    INTEGER, OPTIONAL, INTENT(IN) :: begin
     616    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: bounds(:, :)
     617    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: bounds_name
     618    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: comment
     619    INTEGER, OPTIONAL, INTENT(IN) :: data_begin
     620    INTEGER, OPTIONAL, INTENT(IN) :: data_index(:)
     621    INTEGER, OPTIONAL, INTENT(IN) :: data_n
     622    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: dim_name
     623    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: formula
     624    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: formula_bounds
     625    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: formula_term
     626    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: formula_term_bounds
     627    INTEGER, OPTIONAL, INTENT(IN) :: index(:)
     628    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: label(:)
     629    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: long_name
     630    LOGICAL, OPTIONAL, INTENT(IN) :: mask(:)
     631    INTEGER, OPTIONAL, INTENT(IN) :: n
     632    INTEGER, OPTIONAL, INTENT(IN) :: n_distributed_partition
     633    INTEGER, OPTIONAL, INTENT(IN) :: n_glo
     634    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name
     635    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: positive
     636    INTEGER, OPTIONAL, INTENT(IN) :: prec
     637    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: standard_name
     638    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: unit
     639    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: value(:)
    646640
    647641  END SUBROUTINE xios_set_axis_attr_hdl
    648642
    649643  SUBROUTINE xios_set_field_attr  &
    650     ( field_id, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode, check_if_active  &
    651     , comment, compression_level, default_value, detect_missing_value, domain_ref, enabled, expr  &
    652     , field_ref, freq_offset, freq_op, grid_path, grid_ref, indexed_output, level, long_name, name  &
    653     , operation, prec, read_access, scalar_ref, scale_factor, standard_name, ts_enabled, ts_split_freq  &
    654     , unit, valid_max, valid_min )
    655 
    656     IMPLICIT NONE
    657       TYPE(xios_field) :: field_hdl
    658       CHARACTER(LEN=*), INTENT(IN) ::field_id
    659       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: add_offset
    660       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: axis_ref
    661       LOGICAL  , OPTIONAL, INTENT(IN) :: build_workflow_graph
    662       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: cell_methods
    663       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: cell_methods_mode
    664       LOGICAL  , OPTIONAL, INTENT(IN) :: check_if_active
    665       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: comment
    666       INTEGER  , OPTIONAL, INTENT(IN) :: compression_level
    667       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: default_value
    668       LOGICAL  , OPTIONAL, INTENT(IN) :: detect_missing_value
    669       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: domain_ref
    670       LOGICAL  , OPTIONAL, INTENT(IN) :: enabled
    671       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: expr
    672       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: field_ref
    673       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: freq_offset
    674       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: freq_op
    675       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: grid_path
    676       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: grid_ref
    677       LOGICAL  , OPTIONAL, INTENT(IN) :: indexed_output
    678       INTEGER  , OPTIONAL, INTENT(IN) :: level
    679       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: long_name
    680       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name
    681       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: operation
    682       INTEGER  , OPTIONAL, INTENT(IN) :: prec
    683       LOGICAL  , OPTIONAL, INTENT(IN) :: read_access
    684       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: scalar_ref
    685       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: scale_factor
    686       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: standard_name
    687       LOGICAL  , OPTIONAL, INTENT(IN) :: ts_enabled
    688       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: ts_split_freq
    689       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: unit
    690       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: valid_max
    691       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: valid_min
     644          (field_id, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode, check_if_active  &
     645          , comment, compression_level, default_value, detect_missing_value, domain_ref, enabled, expr  &
     646          , field_ref, freq_offset, freq_op, grid_path, grid_ref, indexed_output, level, long_name, name  &
     647          , operation, prec, read_access, scalar_ref, scale_factor, standard_name, ts_enabled, ts_split_freq  &
     648          , unit, valid_max, valid_min)
     649
     650    IMPLICIT NONE
     651    TYPE(xios_field) :: field_hdl
     652    CHARACTER(LEN = *), INTENT(IN) :: field_id
     653    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: add_offset
     654    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: axis_ref
     655    LOGICAL, OPTIONAL, INTENT(IN) :: build_workflow_graph
     656    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: cell_methods
     657    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: cell_methods_mode
     658    LOGICAL, OPTIONAL, INTENT(IN) :: check_if_active
     659    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: comment
     660    INTEGER, OPTIONAL, INTENT(IN) :: compression_level
     661    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: default_value
     662    LOGICAL, OPTIONAL, INTENT(IN) :: detect_missing_value
     663    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: domain_ref
     664    LOGICAL, OPTIONAL, INTENT(IN) :: enabled
     665    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: expr
     666    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: field_ref
     667    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: freq_offset
     668    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: freq_op
     669    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: grid_path
     670    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: grid_ref
     671    LOGICAL, OPTIONAL, INTENT(IN) :: indexed_output
     672    INTEGER, OPTIONAL, INTENT(IN) :: level
     673    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: long_name
     674    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name
     675    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: operation
     676    INTEGER, OPTIONAL, INTENT(IN) :: prec
     677    LOGICAL, OPTIONAL, INTENT(IN) :: read_access
     678    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: scalar_ref
     679    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: scale_factor
     680    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: standard_name
     681    LOGICAL, OPTIONAL, INTENT(IN) :: ts_enabled
     682    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: ts_split_freq
     683    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: unit
     684    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: valid_max
     685    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: valid_min
    692686
    693687  END SUBROUTINE xios_set_field_attr
    694688
    695689  SUBROUTINE xios_set_field_attr_hdl  &
    696     ( field_hdl, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode, check_if_active  &
    697     , comment, compression_level, default_value, detect_missing_value, domain_ref, enabled, expr  &
    698     , field_ref, freq_offset, freq_op, grid_path, grid_ref, indexed_output, level, long_name, name  &
    699     , operation, prec, read_access, scalar_ref, scale_factor, standard_name, ts_enabled, ts_split_freq  &
    700     , unit, valid_max, valid_min )
    701 
    702     IMPLICIT NONE
    703       TYPE(xios_field) , INTENT(IN) :: field_hdl
    704       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: add_offset
    705       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: axis_ref
    706       LOGICAL  , OPTIONAL, INTENT(IN) :: build_workflow_graph
    707       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: cell_methods
    708       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: cell_methods_mode
    709       LOGICAL  , OPTIONAL, INTENT(IN) :: check_if_active
    710       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: comment
    711       INTEGER  , OPTIONAL, INTENT(IN) :: compression_level
    712       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: default_value
    713       LOGICAL  , OPTIONAL, INTENT(IN) :: detect_missing_value
    714       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: domain_ref
    715       LOGICAL  , OPTIONAL, INTENT(IN) :: enabled
    716       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: expr
    717       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: field_ref
    718       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: freq_offset
    719       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: freq_op
    720       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: grid_path
    721       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: grid_ref
    722       LOGICAL  , OPTIONAL, INTENT(IN) :: indexed_output
    723       INTEGER  , OPTIONAL, INTENT(IN) :: level
    724       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: long_name
    725       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name
    726       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: operation
    727       INTEGER  , OPTIONAL, INTENT(IN) :: prec
    728       LOGICAL  , OPTIONAL, INTENT(IN) :: read_access
    729       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: scalar_ref
    730       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: scale_factor
    731       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: standard_name
    732       LOGICAL  , OPTIONAL, INTENT(IN) :: ts_enabled
    733       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: ts_split_freq
    734       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: unit
    735       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: valid_max
    736       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: valid_min
    737 
     690          (field_hdl, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode, check_if_active  &
     691          , comment, compression_level, default_value, detect_missing_value, domain_ref, enabled, expr  &
     692          , field_ref, freq_offset, freq_op, grid_path, grid_ref, indexed_output, level, long_name, name  &
     693          , operation, prec, read_access, scalar_ref, scale_factor, standard_name, ts_enabled, ts_split_freq  &
     694          , unit, valid_max, valid_min)
     695
     696    IMPLICIT NONE
     697    TYPE(xios_field), INTENT(IN) :: field_hdl
     698    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: add_offset
     699    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: axis_ref
     700    LOGICAL, OPTIONAL, INTENT(IN) :: build_workflow_graph
     701    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: cell_methods
     702    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: cell_methods_mode
     703    LOGICAL, OPTIONAL, INTENT(IN) :: check_if_active
     704    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: comment
     705    INTEGER, OPTIONAL, INTENT(IN) :: compression_level
     706    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: default_value
     707    LOGICAL, OPTIONAL, INTENT(IN) :: detect_missing_value
     708    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: domain_ref
     709    LOGICAL, OPTIONAL, INTENT(IN) :: enabled
     710    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: expr
     711    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: field_ref
     712    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: freq_offset
     713    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: freq_op
     714    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: grid_path
     715    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: grid_ref
     716    LOGICAL, OPTIONAL, INTENT(IN) :: indexed_output
     717    INTEGER, OPTIONAL, INTENT(IN) :: level
     718    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: long_name
     719    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name
     720    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: operation
     721    INTEGER, OPTIONAL, INTENT(IN) :: prec
     722    LOGICAL, OPTIONAL, INTENT(IN) :: read_access
     723    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: scalar_ref
     724    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: scale_factor
     725    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: standard_name
     726    LOGICAL, OPTIONAL, INTENT(IN) :: ts_enabled
     727    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: ts_split_freq
     728    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: unit
     729    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: valid_max
     730    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: valid_min
    738731
    739732  END SUBROUTINE xios_set_field_attr_hdl
    … …  
    741734
    742735  SUBROUTINE xios_set_fieldgroup_attr  &
    743     ( fieldgroup_id, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode  &
    744     , check_if_active, comment, compression_level, default_value, detect_missing_value, domain_ref  &
    745     , enabled, expr, field_ref, freq_offset, freq_op, grid_path, grid_ref, group_ref, indexed_output  &
    746     , level, long_name, name, operation, prec, read_access, scalar_ref, scale_factor, standard_name  &
    747     , ts_enabled, ts_split_freq, unit, valid_max, valid_min )
    748 
    749     IMPLICIT NONE
    750       TYPE(xios_fieldgroup) :: fieldgroup_hdl
    751       CHARACTER(LEN=*), INTENT(IN) ::fieldgroup_id
    752       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: add_offset
    753       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: axis_ref
    754       LOGICAL  , OPTIONAL, INTENT(IN) :: build_workflow_graph
    755       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: cell_methods
    756       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: cell_methods_mode
    757       LOGICAL  , OPTIONAL, INTENT(IN) :: check_if_active
    758       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: comment
    759       INTEGER  , OPTIONAL, INTENT(IN) :: compression_level
    760       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: default_value
    761       LOGICAL  , OPTIONAL, INTENT(IN) :: detect_missing_value
    762       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: domain_ref
    763       LOGICAL  , OPTIONAL, INTENT(IN) :: enabled
    764       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: expr
    765       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: field_ref
    766       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: freq_offset
    767       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: freq_op
    768       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: grid_path
    769       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: grid_ref
    770       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: group_ref
    771       LOGICAL  , OPTIONAL, INTENT(IN) :: indexed_output
    772       INTEGER  , OPTIONAL, INTENT(IN) :: level
    773       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: long_name
    774       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name
    775       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: operation
    776       INTEGER  , OPTIONAL, INTENT(IN) :: prec
    777       LOGICAL  , OPTIONAL, INTENT(IN) :: read_access
    778       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: scalar_ref
    779       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: scale_factor
    780       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: standard_name
    781       LOGICAL  , OPTIONAL, INTENT(IN) :: ts_enabled
    782       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: ts_split_freq
    783       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: unit
    784       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: valid_max
    785       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: valid_min
     736          (fieldgroup_id, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode  &
     737          , check_if_active, comment, compression_level, default_value, detect_missing_value, domain_ref  &
     738          , enabled, expr, field_ref, freq_offset, freq_op, grid_path, grid_ref, group_ref, indexed_output  &
     739          , level, long_name, name, operation, prec, read_access, scalar_ref, scale_factor, standard_name  &
     740          , ts_enabled, ts_split_freq, unit, valid_max, valid_min)
     741
     742    IMPLICIT NONE
     743    TYPE(xios_fieldgroup) :: fieldgroup_hdl
     744    CHARACTER(LEN = *), INTENT(IN) :: fieldgroup_id
     745    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: add_offset
     746    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: axis_ref
     747    LOGICAL, OPTIONAL, INTENT(IN) :: build_workflow_graph
     748    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: cell_methods
     749    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: cell_methods_mode
     750    LOGICAL, OPTIONAL, INTENT(IN) :: check_if_active
     751    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: comment
     752    INTEGER, OPTIONAL, INTENT(IN) :: compression_level
     753    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: default_value
     754    LOGICAL, OPTIONAL, INTENT(IN) :: detect_missing_value
     755    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: domain_ref
     756    LOGICAL, OPTIONAL, INTENT(IN) :: enabled
     757    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: expr
     758    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: field_ref
     759    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: freq_offset
     760    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: freq_op
     761    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: grid_path
     762    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: grid_ref
     763    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: group_ref
     764    LOGICAL, OPTIONAL, INTENT(IN) :: indexed_output
     765    INTEGER, OPTIONAL, INTENT(IN) :: level
     766    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: long_name
     767    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name
     768    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: operation
     769    INTEGER, OPTIONAL, INTENT(IN) :: prec
     770    LOGICAL, OPTIONAL, INTENT(IN) :: read_access
     771    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: scalar_ref
     772    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: scale_factor
     773    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: standard_name
     774    LOGICAL, OPTIONAL, INTENT(IN) :: ts_enabled
     775    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: ts_split_freq
     776    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: unit
     777    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: valid_max
     778    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: valid_min
    786779
    787780  END SUBROUTINE xios_set_fieldgroup_attr
    788781
    789782  SUBROUTINE xios_set_fieldgroup_attr_hdl  &
    790     ( fieldgroup_hdl, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode  &
    791     , check_if_active, comment, compression_level, default_value, detect_missing_value, domain_ref  &
    792     , enabled, expr, field_ref, freq_offset, freq_op, grid_path, grid_ref, group_ref, indexed_output  &
    793     , level, long_name, name, operation, prec, read_access, scalar_ref, scale_factor, standard_name  &
    794     , ts_enabled, ts_split_freq, unit, valid_max, valid_min )
    795 
    796     IMPLICIT NONE
    797       TYPE(xios_fieldgroup) , INTENT(IN) :: fieldgroup_hdl
    798       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: add_offset
    799       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: axis_ref
    800       LOGICAL  , OPTIONAL, INTENT(IN) :: build_workflow_graph
    801       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: cell_methods
    802       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: cell_methods_mode
    803       LOGICAL  , OPTIONAL, INTENT(IN) :: check_if_active
    804       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: comment
    805       INTEGER  , OPTIONAL, INTENT(IN) :: compression_level
    806       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: default_value
    807       LOGICAL  , OPTIONAL, INTENT(IN) :: detect_missing_value
    808       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: domain_ref
    809       LOGICAL  , OPTIONAL, INTENT(IN) :: enabled
    810       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: expr
    811       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: field_ref
    812       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: freq_offset
    813       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: freq_op
    814       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: grid_path
    815       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: grid_ref
    816       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: group_ref
    817       LOGICAL  , OPTIONAL, INTENT(IN) :: indexed_output
    818       INTEGER  , OPTIONAL, INTENT(IN) :: level
    819       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: long_name
    820       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name
    821       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: operation
    822       INTEGER  , OPTIONAL, INTENT(IN) :: prec
    823       LOGICAL  , OPTIONAL, INTENT(IN) :: read_access
    824       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: scalar_ref
    825       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: scale_factor
    826       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: standard_name
    827       LOGICAL  , OPTIONAL, INTENT(IN) :: ts_enabled
    828       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: ts_split_freq
    829       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: unit
    830       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: valid_max
    831       REAL (KIND=8) , OPTIONAL, INTENT(IN) :: valid_min
     783          (fieldgroup_hdl, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode  &
     784          , check_if_active, comment, compression_level, default_value, detect_missing_value, domain_ref  &
     785          , enabled, expr, field_ref, freq_offset, freq_op, grid_path, grid_ref, group_ref, indexed_output  &
     786          , level, long_name, name, operation, prec, read_access, scalar_ref, scale_factor, standard_name  &
     787          , ts_enabled, ts_split_freq, unit, valid_max, valid_min)
     788
     789    IMPLICIT NONE
     790    TYPE(xios_fieldgroup), INTENT(IN) :: fieldgroup_hdl
     791    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: add_offset
     792    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: axis_ref
     793    LOGICAL, OPTIONAL, INTENT(IN) :: build_workflow_graph
     794    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: cell_methods
     795    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: cell_methods_mode
     796    LOGICAL, OPTIONAL, INTENT(IN) :: check_if_active
     797    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: comment
     798    INTEGER, OPTIONAL, INTENT(IN) :: compression_level
     799    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: default_value
     800    LOGICAL, OPTIONAL, INTENT(IN) :: detect_missing_value
     801    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: domain_ref
     802    LOGICAL, OPTIONAL, INTENT(IN) :: enabled
     803    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: expr
     804    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: field_ref
     805    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: freq_offset
     806    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: freq_op
     807    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: grid_path
     808    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: grid_ref
     809    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: group_ref
     810    LOGICAL, OPTIONAL, INTENT(IN) :: indexed_output
     811    INTEGER, OPTIONAL, INTENT(IN) :: level
     812    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: long_name
     813    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name
     814    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: operation
     815    INTEGER, OPTIONAL, INTENT(IN) :: prec
     816    LOGICAL, OPTIONAL, INTENT(IN) :: read_access
     817    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: scalar_ref
     818    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: scale_factor
     819    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: standard_name
     820    LOGICAL, OPTIONAL, INTENT(IN) :: ts_enabled
     821    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: ts_split_freq
     822    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: unit
     823    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: valid_max
     824    REAL (KIND = 8), OPTIONAL, INTENT(IN) :: valid_min
    832825
    833826  END SUBROUTINE xios_set_fieldgroup_attr_hdl
    … …  
    835828
    836829  SUBROUTINE xios_set_file_attr  &
    837     ( file_id, append, comment, compression_level, convention, convention_str, cyclic, description  &
    838     , enabled, format, min_digits, mode, name, name_suffix, output_freq, output_level, par_access  &
    839     , read_metadata_par, record_offset, split_end_offset, split_freq, split_freq_format, split_last_date  &
    840     , split_start_offset, sync_freq, time_counter, time_counter_name, time_stamp_format, time_stamp_name  &
    841     , time_units, timeseries, ts_prefix, type, uuid_format, uuid_name )
    842 
    843     IMPLICIT NONE
    844       TYPE(xios_file) :: file_hdl
    845       CHARACTER(LEN=*), INTENT(IN) ::file_id
    846       LOGICAL  , OPTIONAL, INTENT(IN) :: append
    847       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: comment
    848       INTEGER  , OPTIONAL, INTENT(IN) :: compression_level
    849       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: convention
    850       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: convention_str
    851       LOGICAL  , OPTIONAL, INTENT(IN) :: cyclic
    852       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: description
    853       LOGICAL  , OPTIONAL, INTENT(IN) :: enabled
    854       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: format
    855       INTEGER  , OPTIONAL, INTENT(IN) :: min_digits
    856       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: mode
    857       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name
    858       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name_suffix
    859       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: output_freq
    860       INTEGER  , OPTIONAL, INTENT(IN) :: output_level
    861       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: par_access
    862       LOGICAL  , OPTIONAL, INTENT(IN) :: read_metadata_par
    863       INTEGER  , OPTIONAL, INTENT(IN) :: record_offset
    864       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: split_end_offset
    865       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: split_freq
    866       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: split_freq_format
    867       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: split_last_date
    868       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: split_start_offset
    869       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: sync_freq
    870       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: time_counter
    871       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: time_counter_name
    872       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: time_stamp_format
    873       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: time_stamp_name
    874       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: time_units
    875       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: timeseries
    876       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: ts_prefix
    877       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: type
    878       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: uuid_format
    879       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: uuid_name
     830          (file_id, append, comment, compression_level, convention, convention_str, cyclic, description  &
     831          , enabled, format, min_digits, mode, name, name_suffix, output_freq, output_level, par_access  &
     832          , read_metadata_par, record_offset, split_end_offset, split_freq, split_freq_format, split_last_date  &
     833          , split_start_offset, sync_freq, time_counter, time_counter_name, time_stamp_format, time_stamp_name  &
     834          , time_units, timeseries, ts_prefix, type, uuid_format, uuid_name)
     835
     836    IMPLICIT NONE
     837    TYPE(xios_file) :: file_hdl
     838    CHARACTER(LEN = *), INTENT(IN) :: file_id
     839    LOGICAL, OPTIONAL, INTENT(IN) :: append
     840    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: comment
     841    INTEGER, OPTIONAL, INTENT(IN) :: compression_level
     842    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: convention
     843    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: convention_str
     844    LOGICAL, OPTIONAL, INTENT(IN) :: cyclic
     845    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: description
     846    LOGICAL, OPTIONAL, INTENT(IN) :: enabled
     847    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: format
     848    INTEGER, OPTIONAL, INTENT(IN) :: min_digits
     849    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: mode
     850    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name
     851    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name_suffix
     852    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: output_freq
     853    INTEGER, OPTIONAL, INTENT(IN) :: output_level
     854    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: par_access
     855    LOGICAL, OPTIONAL, INTENT(IN) :: read_metadata_par
     856    INTEGER, OPTIONAL, INTENT(IN) :: record_offset
     857    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: split_end_offset
     858    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: split_freq
     859    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: split_freq_format
     860    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: split_last_date
     861    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: split_start_offset
     862    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: sync_freq
     863    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: time_counter
     864    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: time_counter_name
     865    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: time_stamp_format
     866    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: time_stamp_name
     867    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: time_units
     868    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: timeseries
     869    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: ts_prefix
     870    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: type
     871    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: uuid_format
     872    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: uuid_name
    880873
    881874  END SUBROUTINE xios_set_file_attr
    882875
    883876  SUBROUTINE xios_set_file_attr_hdl  &
    884     ( file_hdl, append, comment, compression_level, convention, convention_str, cyclic, description  &
    885     , enabled, format, min_digits, mode, name, name_suffix, output_freq, output_level, par_access  &
    886     , read_metadata_par, record_offset, split_end_offset, split_freq, split_freq_format, split_last_date  &
    887     , split_start_offset, sync_freq, time_counter, time_counter_name, time_stamp_format, time_stamp_name  &
    888     , time_units, timeseries, ts_prefix, type, uuid_format, uuid_name )
    889 
    890     IMPLICIT NONE
    891       TYPE(xios_file) , INTENT(IN) :: file_hdl
    892       LOGICAL  , OPTIONAL, INTENT(IN) :: append
    893       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: comment
    894       INTEGER  , OPTIONAL, INTENT(IN) :: compression_level
    895       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: convention
    896       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: convention_str
    897       LOGICAL  , OPTIONAL, INTENT(IN) :: cyclic
    898       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: description
    899       LOGICAL  , OPTIONAL, INTENT(IN) :: enabled
    900       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: format
    901       INTEGER  , OPTIONAL, INTENT(IN) :: min_digits
    902       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: mode
    903       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name
    904       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: name_suffix
    905       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: output_freq
    906       INTEGER  , OPTIONAL, INTENT(IN) :: output_level
    907       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: par_access
    908       LOGICAL  , OPTIONAL, INTENT(IN) :: read_metadata_par
    909       INTEGER  , OPTIONAL, INTENT(IN) :: record_offset
    910       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: split_end_offset
    911       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: split_freq
    912       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: split_freq_format
    913       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: split_last_date
    914       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: split_start_offset
    915       TYPE(xios_duration)  , OPTIONAL, INTENT(IN) :: sync_freq
    916       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: time_counter
    917       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: time_counter_name
    918       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: time_stamp_format
    919       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: time_stamp_name
    920       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: time_units
    921       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: timeseries
    922       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: ts_prefix
    923       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: type
    924       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: uuid_format
    925       CHARACTER(len = *) , OPTIONAL, INTENT(IN) :: uuid_name
     877          (file_hdl, append, comment, compression_level, convention, convention_str, cyclic, description  &
     878          , enabled, format, min_digits, mode, name, name_suffix, output_freq, output_level, par_access  &
     879          , read_metadata_par, record_offset, split_end_offset, split_freq, split_freq_format, split_last_date  &
     880          , split_start_offset, sync_freq, time_counter, time_counter_name, time_stamp_format, time_stamp_name  &
     881          , time_units, timeseries, ts_prefix, type, uuid_format, uuid_name)
     882
     883    IMPLICIT NONE
     884    TYPE(xios_file), INTENT(IN) :: file_hdl
     885    LOGICAL, OPTIONAL, INTENT(IN) :: append
     886    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: comment
     887    INTEGER, OPTIONAL, INTENT(IN) :: compression_level
     888    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: convention
     889    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: convention_str
     890    LOGICAL, OPTIONAL, INTENT(IN) :: cyclic
     891    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: description
     892    LOGICAL, OPTIONAL, INTENT(IN) :: enabled
     893    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: format
     894    INTEGER, OPTIONAL, INTENT(IN) :: min_digits
     895    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: mode
     896    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name
     897    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: name_suffix
     898    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: output_freq
     899    INTEGER, OPTIONAL, INTENT(IN) :: output_level
     900    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: par_access
     901    LOGICAL, OPTIONAL, INTENT(IN) :: read_metadata_par
     902    INTEGER, OPTIONAL, INTENT(IN) :: record_offset
     903    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: split_end_offset
     904    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: split_freq
     905    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: split_freq_format
     906    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: split_last_date
     907    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: split_start_offset
     908    TYPE(xios_duration), OPTIONAL, INTENT(IN) :: sync_freq
     909    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: time_counter
     910    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: time_counter_name
     911    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: time_stamp_format
     912    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: time_stamp_name
     913    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: time_units
     914    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: timeseries
     915    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: ts_prefix
     916    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: type
     917    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: uuid_format
     918    CHARACTER(len = *), OPTIONAL, INTENT(IN) :: uuid_name
    926919
    927920  END SUBROUTINE xios_set_file_attr_hdl
    … …  
    929922
    930923  SUBROUTINE xios_is_defined_domain_attr  &
    931     ( domain_id, area, bounds_lat_1d, bounds_lat_2d, bounds_lat_name, bounds_lon_1d, bounds_lon_2d  &
    932     , bounds_lon_name, comment, data_dim, data_i_index, data_ibegin, data_j_index, data_jbegin, data_ni  &
    933     , data_nj, dim_i_name, dim_j_name, domain_ref, i_index, ibegin, j_index, jbegin, lat_name, latvalue_1d  &
    934     , latvalue_2d, lon_name, long_name, lonvalue_1d, lonvalue_2d, mask_1d, mask_2d, name, ni, ni_glo  &
    935     , nj, nj_glo, nvertex, prec, radius, standard_name, type )
    936 
    937     IMPLICIT NONE
    938       CHARACTER(LEN=*), INTENT(IN) ::domain_id
    939       LOGICAL, OPTIONAL, INTENT(OUT) :: area
    940       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_1d
    941       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_2d
    942       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_name
    943       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_1d
    944       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_2d
    945       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_name
    946       LOGICAL, OPTIONAL, INTENT(OUT) :: comment
    947       LOGICAL, OPTIONAL, INTENT(OUT) :: data_dim
    948       LOGICAL, OPTIONAL, INTENT(OUT) :: data_i_index
    949       LOGICAL, OPTIONAL, INTENT(OUT) :: data_ibegin
    950       LOGICAL, OPTIONAL, INTENT(OUT) :: data_j_index
    951       LOGICAL, OPTIONAL, INTENT(OUT) :: data_jbegin
    952       LOGICAL, OPTIONAL, INTENT(OUT) :: data_ni
    953       LOGICAL, OPTIONAL, INTENT(OUT) :: data_nj
    954       LOGICAL, OPTIONAL, INTENT(OUT) :: dim_i_name
    955       LOGICAL, OPTIONAL, INTENT(OUT) :: dim_j_name
    956       LOGICAL, OPTIONAL, INTENT(OUT) :: domain_ref
    957       LOGICAL, OPTIONAL, INTENT(OUT) :: i_index
    958       LOGICAL, OPTIONAL, INTENT(OUT) :: ibegin
    959       LOGICAL, OPTIONAL, INTENT(OUT) :: j_index
    960       LOGICAL, OPTIONAL, INTENT(OUT) :: jbegin
    961       LOGICAL, OPTIONAL, INTENT(OUT) :: lat_name
    962       LOGICAL, OPTIONAL, INTENT(OUT) :: latvalue_1d
    963       LOGICAL, OPTIONAL, INTENT(OUT) :: latvalue_2d
    964       LOGICAL, OPTIONAL, INTENT(OUT) :: lon_name
    965       LOGICAL, OPTIONAL, INTENT(OUT) :: long_name
    966       LOGICAL, OPTIONAL, INTENT(OUT) :: lonvalue_1d
    967       LOGICAL, OPTIONAL, INTENT(OUT) :: lonvalue_2d
    968       LOGICAL, OPTIONAL, INTENT(OUT) :: mask_1d
    969       LOGICAL, OPTIONAL, INTENT(OUT) :: mask_2d
    970       LOGICAL, OPTIONAL, INTENT(OUT) :: name
    971       LOGICAL, OPTIONAL, INTENT(OUT) :: ni
    972       LOGICAL, OPTIONAL, INTENT(OUT) :: ni_glo
    973       LOGICAL, OPTIONAL, INTENT(OUT) :: nj
    974       LOGICAL, OPTIONAL, INTENT(OUT) :: nj_glo
    975       LOGICAL, OPTIONAL, INTENT(OUT) :: nvertex
    976       LOGICAL, OPTIONAL, INTENT(OUT) :: prec
    977       LOGICAL, OPTIONAL, INTENT(OUT) :: radius
    978       LOGICAL, OPTIONAL, INTENT(OUT) :: standard_name
    979       LOGICAL, OPTIONAL, INTENT(OUT) :: type
    980 
    981       area = .FALSE.
    982       bounds_lat_1d = .FALSE.
    983       bounds_lat_2d = .FALSE.
    984       bounds_lat_name = .FALSE.
    985       bounds_lon_1d = .FALSE.
    986       bounds_lon_2d = .FALSE.
    987       bounds_lon_name = .FALSE.
    988       comment = .FALSE.
    989       data_dim = .FALSE.
    990       data_i_index = .FALSE.
    991       data_ibegin = .FALSE.
    992       data_j_index = .FALSE.
    993       data_jbegin = .FALSE.
    994       data_ni = .FALSE.
    995       data_nj = .FALSE.
    996       dim_i_name = .FALSE.
    997       dim_j_name = .FALSE.
    998       domain_ref = .FALSE.
    999       i_index = .FALSE.
    1000       ibegin = .FALSE.
    1001       j_index = .FALSE.
    1002       jbegin = .FALSE.
    1003       lat_name = .FALSE.
    1004       latvalue_1d = .FALSE.
    1005       latvalue_2d = .FALSE.
    1006       lon_name = .FALSE.
    1007       long_name = .FALSE.
    1008       lonvalue_1d = .FALSE.
    1009       lonvalue_2d = .FALSE.
    1010       mask_1d = .FALSE.
    1011       mask_2d = .FALSE.
    1012       name = .FALSE.
    1013       ni = .FALSE.
    1014       ni_glo = .FALSE.
    1015       nj = .FALSE.
    1016       nj_glo = .FALSE.
    1017       nvertex = .FALSE.
    1018       prec = .FALSE.
    1019       radius = .FALSE.
    1020       standard_name = .FALSE.
    1021       type = .FALSE.
     924          (domain_id, area, bounds_lat_1d, bounds_lat_2d, bounds_lat_name, bounds_lon_1d, bounds_lon_2d  &
     925          , bounds_lon_name, comment, data_dim, data_i_index, data_ibegin, data_j_index, data_jbegin, data_ni  &
     926          , data_nj, dim_i_name, dim_j_name, domain_ref, i_index, ibegin, j_index, jbegin, lat_name, latvalue_1d  &
     927          , latvalue_2d, lon_name, long_name, lonvalue_1d, lonvalue_2d, mask_1d, mask_2d, name, ni, ni_glo  &
     928          , nj, nj_glo, nvertex, prec, radius, standard_name, type)
     929
     930    IMPLICIT NONE
     931    CHARACTER(LEN = *), INTENT(IN) :: domain_id
     932    LOGICAL, OPTIONAL, INTENT(OUT) :: area
     933    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_1d
     934    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_2d
     935    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_name
     936    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_1d
     937    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_2d
     938    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_name
     939    LOGICAL, OPTIONAL, INTENT(OUT) :: comment
     940    LOGICAL, OPTIONAL, INTENT(OUT) :: data_dim
     941    LOGICAL, OPTIONAL, INTENT(OUT) :: data_i_index
     942    LOGICAL, OPTIONAL, INTENT(OUT) :: data_ibegin
     943    LOGICAL, OPTIONAL, INTENT(OUT) :: data_j_index
     944    LOGICAL, OPTIONAL, INTENT(OUT) :: data_jbegin
     945    LOGICAL, OPTIONAL, INTENT(OUT) :: data_ni
     946    LOGICAL, OPTIONAL, INTENT(OUT) :: data_nj
     947    LOGICAL, OPTIONAL, INTENT(OUT) :: dim_i_name
     948    LOGICAL, OPTIONAL, INTENT(OUT) :: dim_j_name
     949    LOGICAL, OPTIONAL, INTENT(OUT) :: domain_ref
     950    LOGICAL, OPTIONAL, INTENT(OUT) :: i_index
     951    LOGICAL, OPTIONAL, INTENT(OUT) :: ibegin
     952    LOGICAL, OPTIONAL, INTENT(OUT) :: j_index
     953    LOGICAL, OPTIONAL, INTENT(OUT) :: jbegin
     954    LOGICAL, OPTIONAL, INTENT(OUT) :: lat_name
     955    LOGICAL, OPTIONAL, INTENT(OUT) :: latvalue_1d
     956    LOGICAL, OPTIONAL, INTENT(OUT) :: latvalue_2d
     957    LOGICAL, OPTIONAL, INTENT(OUT) :: lon_name
     958    LOGICAL, OPTIONAL, INTENT(OUT) :: long_name
     959    LOGICAL, OPTIONAL, INTENT(OUT) :: lonvalue_1d
     960    LOGICAL, OPTIONAL, INTENT(OUT) :: lonvalue_2d
     961    LOGICAL, OPTIONAL, INTENT(OUT) :: mask_1d
     962    LOGICAL, OPTIONAL, INTENT(OUT) :: mask_2d
     963    LOGICAL, OPTIONAL, INTENT(OUT) :: name
     964    LOGICAL, OPTIONAL, INTENT(OUT) :: ni
     965    LOGICAL, OPTIONAL, INTENT(OUT) :: ni_glo
     966    LOGICAL, OPTIONAL, INTENT(OUT) :: nj
     967    LOGICAL, OPTIONAL, INTENT(OUT) :: nj_glo
     968    LOGICAL, OPTIONAL, INTENT(OUT) :: nvertex
     969    LOGICAL, OPTIONAL, INTENT(OUT) :: prec
     970    LOGICAL, OPTIONAL, INTENT(OUT) :: radius
     971    LOGICAL, OPTIONAL, INTENT(OUT) :: standard_name
     972    LOGICAL, OPTIONAL, INTENT(OUT) :: type
     973
     974    area = .FALSE.
     975    bounds_lat_1d = .FALSE.
     976    bounds_lat_2d = .FALSE.
     977    bounds_lat_name = .FALSE.
     978    bounds_lon_1d = .FALSE.
     979    bounds_lon_2d = .FALSE.
     980    bounds_lon_name = .FALSE.
     981    comment = .FALSE.
     982    data_dim = .FALSE.
     983    data_i_index = .FALSE.
     984    data_ibegin = .FALSE.
     985    data_j_index = .FALSE.
     986    data_jbegin = .FALSE.
     987    data_ni = .FALSE.
     988    data_nj = .FALSE.
     989    dim_i_name = .FALSE.
     990    dim_j_name = .FALSE.
     991    domain_ref = .FALSE.
     992    i_index = .FALSE.
     993    ibegin = .FALSE.
     994    j_index = .FALSE.
     995    jbegin = .FALSE.
     996    lat_name = .FALSE.
     997    latvalue_1d = .FALSE.
     998    latvalue_2d = .FALSE.
     999    lon_name = .FALSE.
     1000    long_name = .FALSE.
     1001    lonvalue_1d = .FALSE.
     1002    lonvalue_2d = .FALSE.
     1003    mask_1d = .FALSE.
     1004    mask_2d = .FALSE.
     1005    name = .FALSE.
     1006    ni = .FALSE.
     1007    ni_glo = .FALSE.
     1008    nj = .FALSE.
     1009    nj_glo = .FALSE.
     1010    nvertex = .FALSE.
     1011    prec = .FALSE.
     1012    radius = .FALSE.
     1013    standard_name = .FALSE.
     1014    type = .FALSE.
    10221015
    10231016  END SUBROUTINE xios_is_defined_domain_attr
    10241017
    10251018  SUBROUTINE xios_is_defined_domain_attr_hdl  &
    1026     ( domain_hdl, area, bounds_lat_1d, bounds_lat_2d, bounds_lat_name, bounds_lon_1d, bounds_lon_2d  &
    1027     , bounds_lon_name, comment, data_dim, data_i_index, data_ibegin, data_j_index, data_jbegin, data_ni  &
    1028     , data_nj, dim_i_name, dim_j_name, domain_ref, i_index, ibegin, j_index, jbegin, lat_name, latvalue_1d  &
    1029     , latvalue_2d, lon_name, long_name, lonvalue_1d, lonvalue_2d, mask_1d, mask_2d, name, ni, ni_glo  &
    1030     , nj, nj_glo, nvertex, prec, radius, standard_name, type )
    1031 
    1032     IMPLICIT NONE 
    1033       TYPE(xios_domain), INTENT(IN) :: domain_hdl
    1034       LOGICAL, OPTIONAL, INTENT(OUT) :: area
    1035       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_1d
    1036       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_2d
    1037       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_name
    1038       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_1d
    1039       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_2d
    1040       LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_name
    1041       LOGICAL, OPTIONAL, INTENT(OUT) :: comment
    1042       LOGICAL, OPTIONAL, INTENT(OUT) :: data_dim
    1043       LOGICAL, OPTIONAL, INTENT(OUT) :: data_i_index
    1044       LOGICAL, OPTIONAL, INTENT(OUT) :: data_ibegin
    1045       LOGICAL, OPTIONAL, INTENT(OUT) :: data_j_index
    1046       LOGICAL, OPTIONAL, INTENT(OUT) :: data_jbegin
    1047       LOGICAL, OPTIONAL, INTENT(OUT) :: data_ni
    1048       LOGICAL, OPTIONAL, INTENT(OUT) :: data_nj
    1049       LOGICAL, OPTIONAL, INTENT(OUT) :: dim_i_name
    1050       LOGICAL, OPTIONAL, INTENT(OUT) :: dim_j_name
    1051       LOGICAL, OPTIONAL, INTENT(OUT) :: domain_ref
    1052       LOGICAL, OPTIONAL, INTENT(OUT) :: i_index
    1053       LOGICAL, OPTIONAL, INTENT(OUT) :: ibegin
    1054       LOGICAL, OPTIONAL, INTENT(OUT) :: j_index
    1055       LOGICAL, OPTIONAL, INTENT(OUT) :: jbegin
    1056       LOGICAL, OPTIONAL, INTENT(OUT) :: lat_name
    1057       LOGICAL, OPTIONAL, INTENT(OUT) :: latvalue_1d
    1058       LOGICAL, OPTIONAL, INTENT(OUT) :: latvalue_2d
    1059       LOGICAL, OPTIONAL, INTENT(OUT) :: lon_name
    1060       LOGICAL, OPTIONAL, INTENT(OUT) :: long_name
    1061       LOGICAL, OPTIONAL, INTENT(OUT) :: lonvalue_1d
    1062       LOGICAL, OPTIONAL, INTENT(OUT) :: lonvalue_2d
    1063       LOGICAL, OPTIONAL, INTENT(OUT) :: mask_1d
    1064       LOGICAL, OPTIONAL, INTENT(OUT) :: mask_2d
    1065       LOGICAL, OPTIONAL, INTENT(OUT) :: name
    1066       LOGICAL, OPTIONAL, INTENT(OUT) :: ni
    1067       LOGICAL, OPTIONAL, INTENT(OUT) :: ni_glo
    1068       LOGICAL, OPTIONAL, INTENT(OUT) :: nj
    1069       LOGICAL, OPTIONAL, INTENT(OUT) :: nj_glo
    1070       LOGICAL, OPTIONAL, INTENT(OUT) :: nvertex
    1071       LOGICAL, OPTIONAL, INTENT(OUT) :: prec
    1072       LOGICAL, OPTIONAL, INTENT(OUT) :: radius
    1073       LOGICAL, OPTIONAL, INTENT(OUT) :: standard_name
    1074       LOGICAL, OPTIONAL, INTENT(OUT) :: type
    1075 
    1076       area = .FALSE.
    1077       bounds_lat_1d = .FALSE.
    1078       bounds_lat_2d = .FALSE.
    1079       bounds_lat_name = .FALSE.
    1080       bounds_lon_1d = .FALSE.
    1081       bounds_lon_2d = .FALSE.
    1082       bounds_lon_name = .FALSE.
    1083       comment = .FALSE.
    1084       data_dim = .FALSE.
    1085       data_i_index = .FALSE.
    1086       data_ibegin = .FALSE.
    1087       data_j_index = .FALSE.
    1088       data_jbegin = .FALSE.
    1089       data_ni = .FALSE.
    1090       data_nj = .FALSE.
    1091       dim_i_name = .FALSE.
    1092       dim_j_name = .FALSE.
    1093       domain_ref = .FALSE.
    1094       i_index = .FALSE.
    1095       ibegin = .FALSE.
    1096       j_index = .FALSE.
    1097       jbegin = .FALSE.
    1098       lat_name = .FALSE.
    1099       latvalue_1d = .FALSE.
    1100       latvalue_2d = .FALSE.
    1101       lon_name = .FALSE.
    1102       long_name = .FALSE.
    1103       lonvalue_1d = .FALSE.
    1104       lonvalue_2d = .FALSE.
    1105       mask_1d = .FALSE.
    1106       mask_2d = .FALSE.
    1107       name = .FALSE.
    1108       ni = .FALSE.
    1109       ni_glo = .FALSE.
    1110       nj = .FALSE.
    1111       nj_glo = .FALSE.
    1112       nvertex = .FALSE.
    1113       prec = .FALSE.
    1114       radius = .FALSE.
    1115       standard_name = .FALSE.
    1116       type = .FALSE.
     1019          (domain_hdl, area, bounds_lat_1d, bounds_lat_2d, bounds_lat_name, bounds_lon_1d, bounds_lon_2d  &
     1020          , bounds_lon_name, comment, data_dim, data_i_index, data_ibegin, data_j_index, data_jbegin, data_ni  &
     1021          , data_nj, dim_i_name, dim_j_name, domain_ref, i_index, ibegin, j_index, jbegin, lat_name, latvalue_1d  &
     1022          , latvalue_2d, lon_name, long_name, lonvalue_1d, lonvalue_2d, mask_1d, mask_2d, name, ni, ni_glo  &
     1023          , nj, nj_glo, nvertex, prec, radius, standard_name, type)
     1024
     1025    IMPLICIT NONE
     1026    TYPE(xios_domain), INTENT(IN) :: domain_hdl
     1027    LOGICAL, OPTIONAL, INTENT(OUT) :: area
     1028    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_1d
     1029    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_2d
     1030    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lat_name
     1031    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_1d
     1032    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_2d
     1033    LOGICAL, OPTIONAL, INTENT(OUT) :: bounds_lon_name
     1034    LOGICAL, OPTIONAL, INTENT(OUT) :: comment
     1035    LOGICAL, OPTIONAL, INTENT(OUT) :: data_dim
     1036    LOGICAL, OPTIONAL, INTENT(OUT) :: data_i_index
     1037    LOGICAL, OPTIONAL, INTENT(OUT) :: data_ibegin
     1038    LOGICAL, OPTIONAL, INTENT(OUT) :: data_j_index
     1039    LOGICAL, OPTIONAL, INTENT(OUT) :: data_jbegin
     1040    LOGICAL, OPTIONAL, INTENT(OUT) :: data_ni
     1041    LOGICAL, OPTIONAL, INTENT(OUT) :: data_nj
     1042    LOGICAL, OPTIONAL, INTENT(OUT) :: dim_i_name
     1043    LOGICAL, OPTIONAL, INTENT(OUT) :: dim_j_name
     1044    LOGICAL, OPTIONAL, INTENT(OUT) :: domain_ref
     1045    LOGICAL, OPTIONAL, INTENT(OUT) :: i_index
     1046    LOGICAL, OPTIONAL, INTENT(OUT) :: ibegin
     1047    LOGICAL, OPTIONAL, INTENT(OUT) :: j_index
     1048    LOGICAL, OPTIONAL, INTENT(OUT) :: jbegin
     1049    LOGICAL, OPTIONAL, INTENT(OUT) :: lat_name
     1050    LOGICAL, OPTIONAL, INTENT(OUT) :: latvalue_1d
     1051    LOGICAL, OPTIONAL, INTENT(OUT) :: latvalue_2d
     1052    LOGICAL, OPTIONAL, INTENT(OUT) :: lon_name
     1053    LOGICAL, OPTIONAL, INTENT(OUT) :: long_name
     1054    LOGICAL, OPTIONAL, INTENT(OUT) :: lonvalue_1d
     1055    LOGICAL, OPTIONAL, INTENT(OUT) :: lonvalue_2d
     1056    LOGICAL, OPTIONAL, INTENT(OUT) :: mask_1d
     1057    LOGICAL, OPTIONAL, INTENT(OUT) :: mask_2d
     1058    LOGICAL, OPTIONAL, INTENT(OUT) :: name
     1059    LOGICAL, OPTIONAL, INTENT(OUT) :: ni
     1060    LOGICAL, OPTIONAL, INTENT(OUT) :: ni_glo
     1061    LOGICAL, OPTIONAL, INTENT(OUT) :: nj
     1062    LOGICAL, OPTIONAL, INTENT(OUT) :: nj_glo
     1063    LOGICAL, OPTIONAL, INTENT(OUT) :: nvertex
     1064    LOGICAL, OPTIONAL, INTENT(OUT) :: prec
     1065    LOGICAL, OPTIONAL, INTENT(OUT) :: radius
     1066    LOGICAL, OPTIONAL, INTENT(OUT) :: standard_name
     1067    LOGICAL, OPTIONAL, INTENT(OUT) :: type
     1068
     1069    area = .FALSE.
     1070    bounds_lat_1d = .FALSE.
     1071    bounds_lat_2d = .FALSE.
     1072    bounds_lat_name = .FALSE.
     1073    bounds_lon_1d = .FALSE.
     1074    bounds_lon_2d = .FALSE.
     1075    bounds_lon_name = .FALSE.
     1076    comment = .FALSE.
     1077    data_dim = .FALSE.
     1078    data_i_index = .FALSE.
     1079    data_ibegin = .FALSE.
     1080    data_j_index = .FALSE.
     1081    data_jbegin = .FALSE.
     1082    data_ni = .FALSE.
     1083    data_nj = .FALSE.
     1084    dim_i_name = .FALSE.
     1085    dim_j_name = .FALSE.
     1086    domain_ref = .FALSE.
     1087    i_index = .FALSE.
     1088    ibegin = .FALSE.
     1089    j_index = .FALSE.
     1090    jbegin = .FALSE.
     1091    lat_name = .FALSE.
     1092    latvalue_1d = .FALSE.
     1093    latvalue_2d = .FALSE.
     1094    lon_name = .FALSE.
     1095    long_name = .FALSE.
     1096    lonvalue_1d = .FALSE.
     1097    lonvalue_2d = .FALSE.
     1098    mask_1d = .FALSE.
     1099    mask_2d = .FALSE.
     1100    name = .FALSE.
     1101    ni = .FALSE.
     1102    ni_glo = .FALSE.
     1103    nj = .FALSE.
     1104    nj_glo = .FALSE.
     1105    nvertex = .FALSE.
     1106    prec = .FALSE.
     1107    radius = .FALSE.
     1108    standard_name = .FALSE.
     1109    type = .FALSE.
    11171110
    11181111  END SUBROUTINE xios_is_defined_domain_attr_hdl
    11191112
    11201113  SUBROUTINE xios_get_field_attr  &
    1121     ( field_id, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode, check_if_active  &
    1122     , comment, compression_level, default_value, detect_missing_value, domain_ref, enabled, expr  &
    1123     , field_ref, freq_offset, freq_op, grid_path, grid_ref, indexed_output, level, long_name, name  &
    1124     , operation, prec, read_access, scalar_ref, scale_factor, standard_name, ts_enabled, ts_split_freq  &
    1125     , unit, valid_max, valid_min )
    1126 
    1127     IMPLICIT NONE
    1128       TYPE(xios_field) :: field_hdl
    1129       CHARACTER(LEN=*), INTENT(IN) ::field_id
    1130       REAL (KIND=8) , OPTIONAL, INTENT(OUT) :: add_offset
    1131       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: axis_ref
    1132       LOGICAL  , OPTIONAL, INTENT(OUT) :: build_workflow_graph
    1133       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: cell_methods
    1134       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: cell_methods_mode
    1135       LOGICAL  , OPTIONAL, INTENT(OUT) :: check_if_active
    1136       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: comment
    1137       INTEGER  , OPTIONAL, INTENT(OUT) :: compression_level
    1138       REAL (KIND=8) , OPTIONAL, INTENT(OUT) :: default_value
    1139       LOGICAL  , OPTIONAL, INTENT(OUT) :: detect_missing_value
    1140       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: domain_ref
    1141       LOGICAL  , OPTIONAL, INTENT(OUT) :: enabled
    1142       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: expr
    1143       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: field_ref
    1144       TYPE(xios_duration)  , OPTIONAL, INTENT(OUT) :: freq_offset
    1145       TYPE(xios_duration)  , OPTIONAL, INTENT(OUT) :: freq_op
    1146       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: grid_path
    1147       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: grid_ref
    1148       LOGICAL  , OPTIONAL, INTENT(OUT) :: indexed_output
    1149       INTEGER  , OPTIONAL, INTENT(OUT) :: level
    1150       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: long_name
    1151       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: name
    1152       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: operation
    1153       INTEGER  , OPTIONAL, INTENT(OUT) :: prec
    1154       LOGICAL  , OPTIONAL, INTENT(OUT) :: read_access
    1155       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: scalar_ref
    1156       REAL (KIND=8) , OPTIONAL, INTENT(OUT) :: scale_factor
    1157       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: standard_name
    1158       LOGICAL  , OPTIONAL, INTENT(OUT) :: ts_enabled
    1159       TYPE(xios_duration)  , OPTIONAL, INTENT(OUT) :: ts_split_freq
    1160       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: unit
    1161       REAL (KIND=8) , OPTIONAL, INTENT(OUT) :: valid_max
    1162       REAL (KIND=8) , OPTIONAL, INTENT(OUT) :: valid_min
     1114          (field_id, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode, check_if_active  &
     1115          , comment, compression_level, default_value, detect_missing_value, domain_ref, enabled, expr  &
     1116          , field_ref, freq_offset, freq_op, grid_path, grid_ref, indexed_output, level, long_name, name  &
     1117          , operation, prec, read_access, scalar_ref, scale_factor, standard_name, ts_enabled, ts_split_freq  &
     1118          , unit, valid_max, valid_min)
     1119
     1120    IMPLICIT NONE
     1121    TYPE(xios_field) :: field_hdl
     1122    CHARACTER(LEN = *), INTENT(IN) :: field_id
     1123    REAL (KIND = 8), OPTIONAL, INTENT(OUT) :: add_offset
     1124    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: axis_ref
     1125    LOGICAL, OPTIONAL, INTENT(OUT) :: build_workflow_graph
     1126    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: cell_methods
     1127    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: cell_methods_mode
     1128    LOGICAL, OPTIONAL, INTENT(OUT) :: check_if_active
     1129    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: comment
     1130    INTEGER, OPTIONAL, INTENT(OUT) :: compression_level
     1131    REAL (KIND = 8), OPTIONAL, INTENT(OUT) :: default_value
     1132    LOGICAL, OPTIONAL, INTENT(OUT) :: detect_missing_value
     1133    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: domain_ref
     1134    LOGICAL, OPTIONAL, INTENT(OUT) :: enabled
     1135    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: expr
     1136    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: field_ref
     1137    TYPE(xios_duration), OPTIONAL, INTENT(OUT) :: freq_offset
     1138    TYPE(xios_duration), OPTIONAL, INTENT(OUT) :: freq_op
     1139    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: grid_path
     1140    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: grid_ref
     1141    LOGICAL, OPTIONAL, INTENT(OUT) :: indexed_output
     1142    INTEGER, OPTIONAL, INTENT(OUT) :: level
     1143    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: long_name
     1144    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: name
     1145    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: operation
     1146    INTEGER, OPTIONAL, INTENT(OUT) :: prec
     1147    LOGICAL, OPTIONAL, INTENT(OUT) :: read_access
     1148    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: scalar_ref
     1149    REAL (KIND = 8), OPTIONAL, INTENT(OUT) :: scale_factor
     1150    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: standard_name
     1151    LOGICAL, OPTIONAL, INTENT(OUT) :: ts_enabled
     1152    TYPE(xios_duration), OPTIONAL, INTENT(OUT) :: ts_split_freq
     1153    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: unit
     1154    REAL (KIND = 8), OPTIONAL, INTENT(OUT) :: valid_max
     1155    REAL (KIND = 8), OPTIONAL, INTENT(OUT) :: valid_min
    11631156
    11641157  END SUBROUTINE xios_get_field_attr
    11651158
    11661159  SUBROUTINE xios_get_field_attr_hdl  &
    1167     ( field_hdl, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode, check_if_active  &
    1168     , comment, compression_level, default_value, detect_missing_value, domain_ref, enabled, expr  &
    1169     , field_ref, freq_offset, freq_op, grid_path, grid_ref, indexed_output, level, long_name, name  &
    1170     , operation, prec, read_access, scalar_ref, scale_factor, standard_name, ts_enabled, ts_split_freq  &
    1171     , unit, valid_max, valid_min )
    1172 
    1173     IMPLICIT NONE
    1174       TYPE(xios_field) , INTENT(IN) :: field_hdl
    1175       REAL (KIND=8) , OPTIONAL, INTENT(OUT) :: add_offset
    1176       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: axis_ref
    1177       LOGICAL  , OPTIONAL, INTENT(OUT) :: build_workflow_graph
    1178       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: cell_methods
    1179       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: cell_methods_mode
    1180       LOGICAL  , OPTIONAL, INTENT(OUT) :: check_if_active
    1181       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: comment
    1182       INTEGER  , OPTIONAL, INTENT(OUT) :: compression_level
    1183       REAL (KIND=8) , OPTIONAL, INTENT(OUT) :: default_value
    1184       LOGICAL  , OPTIONAL, INTENT(OUT) :: detect_missing_value
    1185       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: domain_ref
    1186       LOGICAL  , OPTIONAL, INTENT(OUT) :: enabled
    1187       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: expr
    1188       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: field_ref
    1189       TYPE(xios_duration)  , OPTIONAL, INTENT(OUT) :: freq_offset
    1190       TYPE(xios_duration)  , OPTIONAL, INTENT(OUT) :: freq_op
    1191       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: grid_path
    1192       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: grid_ref
    1193       LOGICAL  , OPTIONAL, INTENT(OUT) :: indexed_output
    1194       INTEGER  , OPTIONAL, INTENT(OUT) :: level
    1195       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: long_name
    1196       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: name
    1197       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: operation
    1198       INTEGER  , OPTIONAL, INTENT(OUT) :: prec
    1199       LOGICAL  , OPTIONAL, INTENT(OUT) :: read_access
    1200       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: scalar_ref
    1201       REAL (KIND=8) , OPTIONAL, INTENT(OUT) :: scale_factor
    1202       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: standard_name
    1203       LOGICAL  , OPTIONAL, INTENT(OUT) :: ts_enabled
    1204       TYPE(xios_duration)  , OPTIONAL, INTENT(OUT) :: ts_split_freq
    1205       CHARACTER(len = *) , OPTIONAL, INTENT(OUT) :: unit
    1206       REAL (KIND=8) , OPTIONAL, INTENT(OUT) :: valid_max
    1207       REAL (KIND=8) , OPTIONAL, INTENT(OUT) :: valid_min
     1160          (field_hdl, add_offset, axis_ref, build_workflow_graph, cell_methods, cell_methods_mode, check_if_active  &
     1161          , comment, compression_level, default_value, detect_missing_value, domain_ref, enabled, expr  &
     1162          , field_ref, freq_offset, freq_op, grid_path, grid_ref, indexed_output, level, long_name, name  &
     1163          , operation, prec, read_access, scalar_ref, scale_factor, standard_name, ts_enabled, ts_split_freq  &
     1164          , unit, valid_max, valid_min)
     1165
     1166    IMPLICIT NONE
     1167    TYPE(xios_field), INTENT(IN) :: field_hdl
     1168    REAL (KIND = 8), OPTIONAL, INTENT(OUT) :: add_offset
     1169    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: axis_ref
     1170    LOGICAL, OPTIONAL, INTENT(OUT) :: build_workflow_graph
     1171    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: cell_methods
     1172    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: cell_methods_mode
     1173    LOGICAL, OPTIONAL, INTENT(OUT) :: check_if_active
     1174    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: comment
     1175    INTEGER, OPTIONAL, INTENT(OUT) :: compression_level
     1176    REAL (KIND = 8), OPTIONAL, INTENT(OUT) :: default_value
     1177    LOGICAL, OPTIONAL, INTENT(OUT) :: detect_missing_value
     1178    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: domain_ref
     1179    LOGICAL, OPTIONAL, INTENT(OUT) :: enabled
     1180    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: expr
     1181    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: field_ref
     1182    TYPE(xios_duration), OPTIONAL, INTENT(OUT) :: freq_offset
     1183    TYPE(xios_duration), OPTIONAL, INTENT(OUT) :: freq_op
     1184    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: grid_path
     1185    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: grid_ref
     1186    LOGICAL, OPTIONAL, INTENT(OUT) :: indexed_output
     1187    INTEGER, OPTIONAL, INTENT(OUT) :: level
     1188    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: long_name
     1189    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: name
     1190    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: operation
     1191    INTEGER, OPTIONAL, INTENT(OUT) :: prec
     1192    LOGICAL, OPTIONAL, INTENT(OUT) :: read_access
     1193    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: scalar_ref
     1194    REAL (KIND = 8), OPTIONAL, INTENT(OUT) :: scale_factor
     1195    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: standard_name
     1196    LOGICAL, OPTIONAL, INTENT(OUT) :: ts_enabled
     1197    TYPE(xios_duration), OPTIONAL, INTENT(OUT) :: ts_split_freq
     1198    CHARACTER(len = *), OPTIONAL, INTENT(OUT) :: unit
     1199    REAL (KIND = 8), OPTIONAL, INTENT(OUT) :: valid_max
     1200    REAL (KIND = 8), OPTIONAL, INTENT(OUT) :: valid_min
    12081201
    12091202  END SUBROUTINE xios_get_field_attr_hdl
    1210      
     1203
    12111204END MODULE lmdz_xios
    12121205

  • LMDZ6/branches/Amaury_dev/libf/phydev/comcstphy.F90

    r5116 r5119  
    66  REAL :: rcpp    ! specific heat of the atmosphere
    77
    8 end module comcstphy
     8END MODULE comcstphy

  • LMDZ6/branches/Amaury_dev/libf/phydev/iophy.F90

    r5117 r5119  
    2222  END INTERFACE
    2323
    24 contains
     24CONTAINS
    2525
    2626  SUBROUTINE init_iophy_new(rlat, rlon)
    … …  
    389389  END SUBROUTINE histwrite3d_xios
    390390
    391 end module iophy
     391END MODULE iophy

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

    r5117 r5119  
    2222  USE lmdz_grid_phy
    2323  USE lmdz_phys_para
     24  USE lmdz_ssum_scopy, ONLY: scopy
    2425
    2526  IMPLICIT NONE

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/bulk_flux_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  SUBROUTINE bulk_flux(tkt, tks, taur, dter, dser, t_int, s_int, ds_ns, dt_ns, &
    … …  
    153153  END SUBROUTINE  bulk_flux
    154154
    155 end module bulk_flux_m
     155END MODULE bulk_flux_m

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/config_ocean_skin_m.F90

    r5117 r5119  
    2525#endif
    2626
    27 contains
     27CONTAINS
    2828
    2929  SUBROUTINE config_ocean_skin
    … …  
    8080  END SUBROUTINE  config_ocean_skin
    8181
    82 end module config_ocean_skin_m
     82END MODULE config_ocean_skin_m

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/const.F90

    r5117 r5119  
    2525  ! k0829, equation 3.1.13)
    2626
    27 end module const
     27END MODULE const

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/esat_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  elemental real function esat(T, P)
    … …  
    2020  END FUNCTION esat
    2121
    22 end module esat_m
     22END MODULE esat_m

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/fv_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  elemental real function fV(z, rain)
    … …  
    4444  END FUNCTION fV
    4545
    46 end module fv_m
     46END MODULE fv_m

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/microlayer_m.F90

    r5117 r5119  
    33  Implicit none
    44
    5 contains
     5CONTAINS
    66
    77  SUBROUTINE Microlayer(dter, dser, tkt, tks, hlb, tau, s_subskin, al, &
    … …  
    104104  END SUBROUTINE  Microlayer
    105105
    106 end module Microlayer_m
     106END MODULE Microlayer_m

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/mom_flux_rain_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  elemental real function mom_flux_rain(u, rain)
    … …  
    2222  END FUNCTION mom_flux_rain
    2323 
    24 end module mom_flux_rain_m
     24END MODULE mom_flux_rain_m

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/near_surface_m.F90

    r5117 r5119  
    66  ! diurnal warm layer and fresh water lens depth, in m (Zeng and Beljaars 2005)
    77
    8 contains
     8CONTAINS
    99
    1010  SUBROUTINE near_surface(al, t_subskin, s_subskin, ds_ns, dt_ns, tau, taur, &
    … …  
    154154  END SUBROUTINE  Near_Surface
    155155
    156 end module Near_Surface_m
     156END MODULE Near_Surface_m

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/phiw_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  elemental real function Phiw(zL)
    … …  
    2222  END FUNCTION Phiw
    2323
    24 end module Phiw_m
     24END MODULE Phiw_m

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/sens_heat_rain_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77#ifdef IN_LMDZ
    … …  
    6868  END FUNCTION sens_heat_rain
    6969 
    70 end module sens_heat_rain_m
     70END MODULE sens_heat_rain_m

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Ocean_skin/therm_expans_m.F90

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  elemental real function therm_expans(t)
    … …  
    1717  END FUNCTION therm_expans
    1818
    19 end module therm_expans_m
     19END MODULE therm_expans_m

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

    r5117 r5119  
    66  IMPLICIT NONE
    77
    8 contains
     8CONTAINS
    99
    1010  SUBROUTINE ACAMA_GWD_rando(DTIME, pp, plat, tt, uu, vv, rot, &
    … …  
    535535  END SUBROUTINE ACAMA_GWD_RANDO
    536536
    537 end module ACAMA_GWD_rando_m
     537END MODULE ACAMA_GWD_rando_m

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

    r5117 r5119  
    44  IMPLICIT NONE
    55
    6 contains
     6CONTAINS
    77
    88  SUBROUTINE alboc(rjour, rlat, albedo)
    … …  
    159159  END SUBROUTINE alboc_cd
    160160
    161 end module albedo
     161END MODULE albedo

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

    r5116 r5119  
    22   stop 'In call_ini_replay : You should run replay_equip.sh before runing replay[13]d'
    33   RETURN
    4    end
     4   END

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

    r5117 r5119  
    33   stop 'In call_param_replay : You should run replay_equip.sh before runing replay[13]d'
    44   RETURN
    5    end
     5   END

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

    r5117 r5119  
    549549      return
    550550
    551       end
     551      END

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

    r5117 r5119  
    1010  public COARE30_FLUX_CNRM
    1111
    12 contains
     12CONTAINS
    1313
    1414
    … …  
    583583END SUBROUTINE COARE30_FLUX_CNRM
    584584
    585 end module coare30_flux_cnrm_mod
     585END MODULE coare30_flux_cnrm_mod

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

    r5117 r5119  
    44  public psit_30, psiuo, coare_cp
    55
    6 contains
     6CONTAINS
    77
    88  REAL function psit_30(zet)
    … …  
    247247END SUBROUTINE  coare_cp
    248248
    249 end module coare_cp_mod
     249END MODULE coare_cp_mod

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

    r5117 r5119  
    978978    ENDDO
    979979
    980 
    981980  END SUBROUTINE dyn1dredem
    982981
    983982
    984983  SUBROUTINE gr_fi_dyn(nfield, ngrid, im, jm, pfi, pdyn)
     984    USE lmdz_ssum_scopy, ONLY: scopy
     985
    985986    IMPLICIT NONE
    986987    !=======================================================================
    … …  
    10161017      ENDDO
    10171018    ENDDO
    1018 
    10191019
    10201020  END SUBROUTINE gr_fi_dyn
    … …  
    14691469    print *, 't_targ', t_targ
    14701470    print *, 'rh_targ', rh_targ
    1471 
    14721471
    14731472  END SUBROUTINE nudge_rht_init

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

    r5117 r5119  
    561561    WRITE(*, *) ' '
    562562
    563   end
     563  END
    564564  SUBROUTINE mesolupbis(file_forctl)
    565565    !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    … …  
    773773
    774774    RETURN
    775   end
     775  END
    776776  SUBROUTINE GETSCH(STR, DEL, TRM, NTH, SST, NCH)
    777777    !***************************************************************

  • LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/old_1DUTILS_read_interp.h

    r5117 r5119  
    138138
    139139          RETURN
    140           end
     140          END
    141141!=====================================================================
    142142      subroutine read_twpice(fich_twpice,nlevel,ntime                       &
    … …  
    534534
    535535       RETURN
    536        end
     536       END
    537537!=====================================================================
    538538
    … …  
    647647
    648648          RETURN
    649           end
     649          END
    650650!=====================================================================
    651651       SUBROUTINE interp_astex_vertical(play,nlev_astex,plev_prof          &
    … …  
    11601160 
    11611161          RETURN
    1162           end
     1162          END
    11631163 
    11641164!=====================================================================
    … …  
    13191319 
    13201320          RETURN
    1321           end
     1321          END
    13221322!*****************************************************************************
    13231323!=====================================================================
    … …  
    20292029
    20302030        RETURN
    2031         end
     2031        END
    20322032!======================================================================
    20332033      subroutine readprofile_sandu(nlev_max,kmax,height,pprof,tprof,       &

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

    r5117 r5119  
    11PROGRAM rejouer
    22
    3 USE mod_const_mpi, ONLY: comm_lmdz
    4 USE inigeomphy_mod, ONLY: inigeomphy
    5 USE comvert_mod, ONLY: presnivs
    6 USE comvert_mod, ONLY:  preff, pa
    7 USE ioipsl, ONLY: getin
     3  USE mod_const_mpi, ONLY: comm_lmdz
     4  USE inigeomphy_mod, ONLY: inigeomphy
     5  USE comvert_mod, ONLY: presnivs
     6  USE comvert_mod, ONLY: preff, pa
     7  USE ioipsl, ONLY: getin
     8
     9  IMPLICIT NONE
     10  INCLUDE "dimensions.h"
     11
     12  REAL :: airefi
     13  REAL :: zcufi = 1.
     14  REAL :: zcvfi = 1.
     15  REAL :: rlat_rad(1), rlon_rad(1)
     16
     17  INTEGER ntime
     18  INTEGER jour0, mois0, an0, day_step, anneeref, dayref
     19  INTEGER klev, klon
     20  CHARACTER (len = 10) :: calend
     21  CHARACTER(len = 20) :: calendrier
    822
    923
     24  !---------------------------------------------------------------------
     25  ! L'appel a inigeomphy n'est utile que pour avoir getin_p dans
     26  ! les initialisations
     27  !---------------------------------------------------------------------
     28  zcufi = 1.
     29  zcvfi = 1.
     30  rlat_rad(1) = 0.
     31  rlon_rad(1) = 0.
    1032
     33  preff = 101325.
     34  !preff=100000.
     35  pa = 50000.
     36  CALL disvert()
     37  CALL inigeomphy(1, 1, llm, &
     38          1, comm_lmdz, &
     39          (/rlat_rad(1), 0./), (/0./), &
     40          (/0., 0./), (/rlon_rad(1), 0./), &
     41          (/ (/airefi, 0./), (/0., 0./) /), &
     42          (/zcufi, 0., 0., 0./), &
     43          (/zcvfi, 0./))
    1144
    12       IMPLICIT NONE
    13       INCLUDE "dimensions.h"
     45  CALL suphel
     46  !ntime=4320
     47  ntime = 10000000
     48  dayref = 1
     49  anneeref = 2000
     50  CALL getin('dayref', dayref)
     51  CALL getin('anneeref', anneeref)
     52  CALL getin('calend', calend)
     53  CALL getin('day_step', day_step)
     54  calendrier = calend
     55  IF (calendrier == "earth_360d") calendrier = "360_day"
    1456
    15 REAL :: airefi
    16 REAL :: zcufi    = 1.
    17 REAL :: zcvfi    = 1.
    18 REAL :: rlat_rad(1),rlon_rad(1)
     57  jour0 = dayref
     58  mois0 = (jour0 - 1) / 30 + 1
     59  jour0 = jour0 - 30 * ((jour0 - 1) / 30)
     60  an0 = anneeref
    1961
    20 INTEGER ntime
    21 INTEGER jour0,mois0,an0,day_step,anneeref,dayref
    22 INTEGER klev,klon
    23 CHARACTER (len=10) :: calend
    24 CHARACTER(len=20) :: calendrier
     62  !PRINT*,"REPLAY1D jour0,mois0,an0",jour0,mois0,an0
    2563
     64  klon = 1
     65  klev = llm
     66  CALL iotd_ini('phys.nc', 1, 1, klev, 0., 0., presnivs, jour0, mois0, an0, 0., 86400. / day_step, calendrier)
     67  ! Consistent with ... CALL iophys_ini(600.)
    2668
    27 !---------------------------------------------------------------------
    28 ! L'appel a inigeomphy n'est utile que pour avoir getin_p dans
    29 ! les initialisations
    30 !---------------------------------------------------------------------
    31   zcufi=1.
    32   zcvfi=1.
    33   rlat_rad(1)=0.
    34   rlon_rad(1)=0.
     69  !---------------------------------------------------------------------
     70  ! Initialisation de la parametrisation
     71  !---------------------------------------------------------------------
     72  CALL call_ini_replay
    3573
    36 preff=101325.
    37 !preff=100000.
    38 pa=50000.
    39   CALL disvert()
    40   CALL inigeomphy(1,1,llm, &
    41                1, comm_lmdz, &
    42            (/rlat_rad(1),0./),(/0./), &
    43            (/0.,0./),(/rlon_rad(1),0./),  &
    44            (/ (/airefi,0./),(/0.,0./) /), &
    45            (/zcufi,0.,0.,0./), &
    46            (/zcvfi,0./))
    47 
    48 CALL suphel
    49 !ntime=4320
    50 ntime=10000000
    51 dayref=1
    52 anneeref=2000
    53 CALL getin('dayref',dayref)
    54 CALL getin('anneeref',anneeref)
    55 CALL getin('calend',calend)
    56 CALL getin('day_step',day_step)
    57 calendrier=calend
    58 IF ( calendrier == "earth_360d" ) calendrier="360_day"
    59 
    60 
    61 jour0=dayref
    62 mois0=(jour0-1)/30+1
    63 jour0=jour0-30*((jour0-1)/30)
    64 an0=anneeref
    65 
    66 !PRINT*,"REPLAY1D jour0,mois0,an0",jour0,mois0,an0
    67 
    68 
    69 klon=1
    70 klev=llm
    71 CALL iotd_ini('phys.nc',1,1,klev,0.,0.,presnivs,jour0,mois0,an0,0.,86400./day_step,calendrier)
    72 ! Consistent with ... CALL iophys_ini(600.)
    73 
    74 !---------------------------------------------------------------------
    75 ! Initialisation de la parametrisation
    76 !---------------------------------------------------------------------
    77 CALL call_ini_replay
    78 
    79 !---------------------------------------------------------------------
    80 ! Boucle en temps sur l'appel à la parametrisation
    81 !---------------------------------------------------------------------
    82 CALL call_param_replay(klon,klev)
     74  !---------------------------------------------------------------------
     75  ! Boucle en temps sur l'appel à la parametrisation
     76  !---------------------------------------------------------------------
     77  CALL call_param_replay(klon, klev)
    8378
    8479end
    … …  
    9388
    9489!=======================================================================
    95       SUBROUTINE abort_gcm(modname, message, ierr)
    96       USE IOIPSL
    97 ! Stops the simulation cleanly, closing files and printing various
    98 ! comments
    99 !=======================================================================
     90SUBROUTINE abort_gcm(modname, message, ierr)
     91  USE IOIPSL
     92  ! Stops the simulation cleanly, closing files and printing various
     93  ! comments
     94  !=======================================================================
    10095
    101 !  Input: modname = name of calling program
    102 !         message = stuff to print
    103 !         ierr    = severity of situation ( = 0 normal )
    104  
    105       CHARACTER(LEN=*) modname
    106       INTEGER ierr
    107       CHARACTER(LEN=*) message
    108  
    109       WRITE(*,*) 'in abort_gcm'
    110       CALL histclo
    111       WRITE(*,*) 'out of histclo'
    112       WRITE(*,*) 'Stopping in ', modname
    113       WRITE(*,*) 'Reason = ',message
    114       CALL getin_dump
     96  !  Input: modname = name of calling program
     97  !         message = stuff to print
     98  !         ierr    = severity of situation ( = 0 normal )
    11599
    116       IF (ierr == 0) THEN
    117         WRITE(*,*) 'Everything is cool'
    118       else
    119         WRITE(*,*) 'Houston, we have a problem ', ierr
    120       endif
    121       STOP
    122       END
     100  CHARACTER(LEN = *) modname
     101  INTEGER ierr
     102  CHARACTER(LEN = *) message
     103
     104  WRITE(*, *) 'in abort_gcm'
     105  CALL histclo
     106  WRITE(*, *) 'out of histclo'
     107  WRITE(*, *) 'Stopping in ', modname
     108  WRITE(*, *) 'Reason = ', message
     109  CALL getin_dump
     110
     111  IF (ierr == 0) THEN
     112    WRITE(*, *) 'Everything is cool'
     113  else
     114    WRITE(*, *) 'Houston, we have a problem ', ierr
     115  endif
     116  STOP
     117END
    123118
    124119!=======================================================================
    125       SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi)
    126       IMPLICIT NONE
    127 !   passage d'un champ de la grille scalaire a la grille physique
    128 !=======================================================================
    129  
    130 !-----------------------------------------------------------------------
    131 !   declarations:
    132 !   -------------
    133  
    134       INTEGER im,jm,ngrid,nfield
    135       REAL pdyn(im,jm,nfield)
    136       REAL pfi(ngrid,nfield)
    137  
    138       INTEGER j,ifield,ig
    139  
    140 !-----------------------------------------------------------------------
    141 !   calcul:
    142 !   -------
    143  
    144       IF(ngrid/=2+(jm-2)*(im-1).AND.ngrid/=1)                          &
    145       STOP 'probleme de dim'
    146 !   traitement des poles
    147       CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid)
    148       CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid)
    149  
    150 !   traitement des point normaux
    151       DO ifield=1,nfield
    152          DO j=2,jm-1
    153             ig=2+(j-2)*(im-1)
    154             CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1)
    155          ENDDO
    156       ENDDO
    157  
    158       RETURN
    159       END
     120SUBROUTINE gr_dyn_fi(nfield, im, jm, ngrid, pdyn, pfi)
     121  USE lmdz_ssum_scopy, ONLY: scopy
     122
     123  IMPLICIT NONE
     124  !   passage d'un champ de la grille scalaire a la grille physique
     125  !=======================================================================
     126
     127  !-----------------------------------------------------------------------
     128  !   declarations:
     129  !   -------------
     130
     131  INTEGER im, jm, ngrid, nfield
     132  REAL pdyn(im, jm, nfield)
     133  REAL pfi(ngrid, nfield)
     134
     135  INTEGER j, ifield, ig
     136
     137  !-----------------------------------------------------------------------
     138  !   calcul:
     139  !   -------
     140
     141  IF(ngrid/=2 + (jm - 2) * (im - 1).AND.ngrid/=1)                          &
     142          STOP 'probleme de dim'
     143  !   traitement des poles
     144  CALL SCOPY(nfield, pdyn, im * jm, pfi, ngrid)
     145  CALL SCOPY(nfield, pdyn(1, jm, 1), im * jm, pfi(ngrid, 1), ngrid)
     146
     147  !   traitement des point normaux
     148  DO ifield = 1, nfield
     149    DO j = 2, jm - 1
     150      ig = 2 + (j - 2) * (im - 1)
     151      CALL SCOPY(im - 1, pdyn(1, j, ifield), 1, pfi(ig, ifield), 1)
     152    ENDDO
     153  ENDDO
     154
     155  RETURN
     156END

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

    r5117 r5119  
    55  IMPLICIT NONE
    66
    7 contains
     7CONTAINS
    88
    99  SUBROUTINE FLOTT_GWD_rando(DTIME, pp, tt, uu, vv, prec, zustr, zvstr, d_u, &
    … …  
    455455  END SUBROUTINE FLOTT_GWD_RANDO
    456456
    457 end module FLOTT_GWD_rando_m
     457END MODULE FLOTT_GWD_rando_m

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

    r5117 r5119  
    1919END DO
    2020RETURN
    21 end
     21END

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

    r5117 r5119  
    33  IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77  SUBROUTINE hbtm(knon, paprs, pplay, t2m, t10m, q2m, q10m, ustar, wstar, &
    … …  
    767767  END SUBROUTINE hbtm
    768768
    769 end module hbtm_mod
     769END MODULE hbtm_mod

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

    r5117 r5119  
    261261
    262262      RETURN
    263       end
    264 
     263      END
     264

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

    r5117 r5119  
    182182
    183183
    184       end
     184      END

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

    r5117 r5119  
    33IMPLICIT NONE
    44
    5 contains
     5CONTAINS
    66
    77SUBROUTINE atke_compute_km_kh(ngrid,nlay,dtime, &
    … …  
    511511
    512512
    513 end module lmdz_atke_exchange_coeff
     513END MODULE lmdz_atke_exchange_coeff

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

    r5117 r5119  
    2929
    3030
    31     contains
     31CONTAINS
    3232
    3333   SUBROUTINE blowing_snow_ini(RCPD_in, RLSTT_in, RLVTT_in, RLMLT_in,&
    … …  
    8484      END SUBROUTINE  blowing_snow_ini
    8585
    86 end module lmdz_blowing_snow_ini
     86END MODULE lmdz_blowing_snow_ini

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

    r5117 r5119  
    11module lmdz_blowing_snow_sublim_sedim
    22
    3 contains
     3CONTAINS
    44SUBROUTINE blowing_snow_sublim_sedim(ngrid,nlay,dtime,temp,qv,qb,pplay,paprs,dtemp_bs,dqv_bs,dqb_bs,bsfl,precip_bs)
    55
    … …  
    293293
    294294END SUBROUTINE  blowing_snow_sublim_sedim
    295 end module lmdz_blowing_snow_sublim_sedim
     295END MODULE lmdz_blowing_snow_sublim_sedim

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

    r5117 r5119  
    66
    77
    8 contains
     8CONTAINS
    99
    1010SUBROUTINE call_atke(dtime,ngrid,nlay,nsrf,ni,cdrag_uv,cdrag_t,u_surf,v_surf,temp_surf, &
    … …  
    172172
    173173
    174 end module lmdz_call_atke
     174END MODULE lmdz_call_atke

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

    r5117 r5119  
    11module lmdz_call_blowing_snow
    22
    3 contains
     3CONTAINS
    44
    55SUBROUTINE call_blowing_snow_sublim_sedim(ngrid,nlay,dtime,temp,q,qbs,pplay,paprs, &
    … …  
    4343END SUBROUTINE  call_blowing_snow_sublim_sedim
    4444
    45 end module lmdz_call_blowing_snow
     45END MODULE lmdz_call_blowing_snow

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

    r5117 r5119  
    88
    99
    10 contains
     10CONTAINS
    1111
    1212SUBROUTINE cloudth_ini(iflag_cloudth_vert_in,iflag_ratqs_in)
    … …  
    5151END SUBROUTINE  cloudth_ini
    5252
    53 end module lmdz_cloudth_ini
     53END MODULE lmdz_cloudth_ini

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

    r5117 r5119  
    425425
    426426      RETURN
    427       end
     427      END
    428428END MODULE lmdz_thermcell_alp

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

    r5117 r5119  
    7272
    7373 RETURN
    74       end
     74      END
    7575END MODULE lmdz_thermcell_closure

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

    r5117 r5119  
    326326
    327327    RETURN
    328   end
     328  END
    329329END MODULE lmdz_thermcell_dq

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

    r5117 r5119  
    121121
    122122      RETURN
    123       end
     123      END
    124124END MODULE lmdz_thermcell_dtke

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

    r5117 r5119  
    194194
    195195      RETURN
    196       end
     196      END
    197197END MODULE lmdz_thermcell_dv2

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

    r5117 r5119  
    503503
    504504    RETURN
    505   end
     505  END
    506506END MODULE lmdz_thermcell_flux2

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

    r5117 r5119  
    168168
    169169 RETURN
    170       end
     170      END
    171171END MODULE lmdz_thermcell_height

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

    r5117 r5119  
    22CONTAINS
    33
    4 SUBROUTINE thermcell_2002(ngrid, nlay, ptimestep, iflag_thermals, pplay, &
    5     pplev, pphi, pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0, &
    6     fraca, wa_moy, r_aspect, l_mix, w2di, tho)
    7 
    8   USE dimphy
    9   USE lmdz_write_field_phy
    10   USE lmdz_thermcell_dv2, ONLY: thermcell_dv2
    11   USE lmdz_thermcell_dq, ONLY: thermcell_dq
    12   USE lmdz_abort_physic, ONLY: abort_physic
    13   IMPLICIT NONE
    14 
    15   ! =======================================================================
    16 
    17   ! Calcul du transport verticale dans la couche limite en presence
    18   ! de "thermiques" explicitement representes
    19 
    20   ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
    21 
    22   ! le thermique est supposé homogène et dissipé par mélange avec
    23   ! son environnement. la longueur l_mix contrôle l'efficacité du
    24   ! mélange
    25 
    26   ! Le calcul du transport des différentes espèces se fait en prenant
    27   ! en compte:
    28   ! 1. un flux de masse montant
    29   ! 2. un flux de masse descendant
    30   ! 3. un entrainement
    31   ! 4. un detrainement
    32 
    33   ! =======================================================================
    34 
    35   ! -----------------------------------------------------------------------
    36   ! declarations:
    37   ! -------------
    38 
    39   include "YOMCST.h"
    40 
    41   ! arguments:
    42   ! ----------
    43 
    44   INTEGER ngrid, nlay, w2di, iflag_thermals
    45   REAL tho
    46   REAL ptimestep, l_mix, r_aspect
    47   REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
    48   REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
    49   REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
    50   REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
    51   REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1)
    52   REAL pphi(ngrid, nlay)
    53   REAL fraca(ngrid, nlay+1), zw2(ngrid, nlay+1)
    54 
    55   INTEGER, SAVE :: idetr = 3, lev_out = 1
    56   !$OMP THREADPRIVATE(idetr,lev_out)
    57 
    58   ! local:
    59   ! ------
    60 
    61   INTEGER, SAVE :: dvdq = 0, flagdq = 0, dqimpl = 1
    62   LOGICAL, SAVE :: debut = .TRUE.
    63   !$OMP THREADPRIVATE(dvdq,flagdq,debut,dqimpl)
    64 
    65   INTEGER ig, k, l, lmax(klon, klev+1), lmaxa(klon), lmix(klon)
    66   REAL zmax(klon), zw, zz, ztva(klon, klev), zzz
    67 
    68   REAL zlev(klon, klev+1), zlay(klon, klev)
    69   REAL zh(klon, klev), zdhadj(klon, klev)
    70   REAL ztv(klon, klev)
    71   REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
    72   REAL wh(klon, klev+1)
    73   REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1)
    74   REAL zla(klon, klev+1)
    75   REAL zwa(klon, klev+1)
    76   REAL zld(klon, klev+1)
    77   REAL zwd(klon, klev+1)
    78   REAL zsortie(klon, klev)
    79   REAL zva(klon, klev)
    80   REAL zua(klon, klev)
    81   REAL zoa(klon, klev)
    82 
    83   REAL zha(klon, klev)
    84   REAL wa_moy(klon, klev+1)
    85   REAL fracc(klon, klev+1)
    86   REAL zf, zf2
    87   REAL thetath2(klon, klev), wth2(klon, klev)
    88   ! common/comtherm/thetath2,wth2
    89 
    90   REAL count_time
    91 
    92   LOGICAL sorties
    93   REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev)
    94   REAL zpspsk(klon, klev)
    95 
    96   REAL wmax(klon, klev), wmaxa(klon)
    97 
    98   REAL wa(klon, klev, klev+1)
    99   REAL wd(klon, klev+1)
    100   REAL larg_part(klon, klev, klev+1)
    101   REAL fracd(klon, klev+1)
    102   REAL xxx(klon, klev+1)
    103   REAL larg_cons(klon, klev+1)
    104   REAL larg_detr(klon, klev+1)
    105   REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev)
    106   REAL pu_therm(klon, klev), pv_therm(klon, klev)
    107   REAL fm(klon, klev+1), entr(klon, klev)
    108   REAL fmc(klon, klev+1)
    109 
    110   CHARACTER (LEN=2) :: str2
    111   CHARACTER (LEN=10) :: str10
    112 
    113   CHARACTER (LEN=20) :: modname = 'thermcell2002'
    114   CHARACTER (LEN=80) :: abort_message
    115 
    116   LOGICAL vtest(klon), down
    117 
    118   EXTERNAL scopy
    119 
    120   INTEGER ncorrec, ll
    121   SAVE ncorrec
    122   DATA ncorrec/0/
    123   !$OMP THREADPRIVATE(ncorrec)
    124 
    125 
    126   ! -----------------------------------------------------------------------
    127   ! initialisation:
    128   ! ---------------
    129 
    130   sorties = .TRUE.
    131   IF (ngrid/=klon) THEN
    132     PRINT *
    133     PRINT *, 'STOP dans convadj'
    134     PRINT *, 'ngrid    =', ngrid
    135     PRINT *, 'klon  =', klon
    136   END IF
    137 
    138   ! -----------------------------------------------------------------------
    139   ! incrementation eventuelle de tendances precedentes:
    140   ! ---------------------------------------------------
    141 
    142   ! PRINT*,'0 OK convect8'
    143 
    144   DO l = 1, nlay
    145     DO ig = 1, ngrid
    146       zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa
    147       zh(ig, l) = pt(ig, l)/zpspsk(ig, l)
    148       zu(ig, l) = pu(ig, l)
    149       zv(ig, l) = pv(ig, l)
    150       zo(ig, l) = po(ig, l)
    151       ztv(ig, l) = zh(ig, l)*(1.+0.61*zo(ig,l))
    152     END DO
    153   END DO
    154 
    155   ! PRINT*,'1 OK convect8'
    156   ! --------------------
    157 
    158 
    159   ! + + + + + + + + + + +
    160 
    161 
    162   ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
    163   ! wh,wt,wo ...
    164 
    165   ! + + + + + + + + + + +  zh,zu,zv,zo,rho
    166 
    167 
    168   ! --------------------   zlev(1)
    169   ! \\\\\\\\\\\\\\\\\\\\
    170 
    171 
    172 
    173   ! -----------------------------------------------------------------------
    174   ! Calcul des altitudes des couches
    175   ! -----------------------------------------------------------------------
    176 
    177   IF (debut) THEN
    178     flagdq = (iflag_thermals-1000)/100
    179     dvdq = (iflag_thermals-(1000+flagdq*100))/10
    180     IF (flagdq==2) dqimpl = -1
    181     IF (flagdq==3) dqimpl = 1
    182     debut = .FALSE.
    183   END IF
    184   PRINT *, 'TH flag th ', iflag_thermals, flagdq, dvdq, dqimpl
    185 
    186   DO l = 2, nlay
    187     DO ig = 1, ngrid
    188       zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg
    189     END DO
    190   END DO
    191   DO ig = 1, ngrid
    192     zlev(ig, 1) = 0.
    193     zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg
    194   END DO
    195   DO l = 1, nlay
    196     DO ig = 1, ngrid
    197       zlay(ig, l) = pphi(ig, l)/rg
    198     END DO
    199   END DO
    200 
    201   ! PRINT*,'2 OK convect8'
    202   ! -----------------------------------------------------------------------
    203   ! Calcul des densites
    204   ! -----------------------------------------------------------------------
    205 
    206   DO l = 1, nlay
    207     DO ig = 1, ngrid
    208       rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*zh(ig,l))
    209     END DO
    210   END DO
    211 
    212   DO l = 2, nlay
    213     DO ig = 1, ngrid
    214       rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1))
    215     END DO
    216   END DO
    217 
    218   DO k = 1, nlay
     4  SUBROUTINE thermcell_2002(ngrid, nlay, ptimestep, iflag_thermals, pplay, &
     5          pplev, pphi, pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0, &
     6          fraca, wa_moy, r_aspect, l_mix, w2di, tho)
     7
     8    USE dimphy
     9    USE lmdz_write_field_phy
     10    USE lmdz_thermcell_dv2, ONLY: thermcell_dv2
     11    USE lmdz_thermcell_dq, ONLY: thermcell_dq
     12    USE lmdz_abort_physic, ONLY: abort_physic
     13    IMPLICIT NONE
     14
     15    ! =======================================================================
     16
     17    ! Calcul du transport verticale dans la couche limite en presence
     18    ! de "thermiques" explicitement representes
     19
     20    ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
     21
     22    ! le thermique est supposé homogène et dissipé par mélange avec
     23    ! son environnement. la longueur l_mix contrôle l'efficacité du
     24    ! mélange
     25
     26    ! Le calcul du transport des différentes espèces se fait en prenant
     27    ! en compte:
     28    ! 1. un flux de masse montant
     29    ! 2. un flux de masse descendant
     30    ! 3. un entrainement
     31    ! 4. un detrainement
     32
     33    ! =======================================================================
     34
     35    ! -----------------------------------------------------------------------
     36    ! declarations:
     37    ! -------------
     38
     39    include "YOMCST.h"
     40
     41    ! arguments:
     42    ! ----------
     43
     44    INTEGER ngrid, nlay, w2di, iflag_thermals
     45    REAL tho
     46    REAL ptimestep, l_mix, r_aspect
     47    REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
     48    REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
     49    REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
     50    REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
     51    REAL pplay(ngrid, nlay), pplev(ngrid, nlay + 1)
     52    REAL pphi(ngrid, nlay)
     53    REAL fraca(ngrid, nlay + 1), zw2(ngrid, nlay + 1)
     54
     55    INTEGER, SAVE :: idetr = 3, lev_out = 1
     56    !$OMP THREADPRIVATE(idetr,lev_out)
     57
     58    ! local:
     59    ! ------
     60
     61    INTEGER, SAVE :: dvdq = 0, flagdq = 0, dqimpl = 1
     62    LOGICAL, SAVE :: debut = .TRUE.
     63    !$OMP THREADPRIVATE(dvdq,flagdq,debut,dqimpl)
     64
     65    INTEGER ig, k, l, lmax(klon, klev + 1), lmaxa(klon), lmix(klon)
     66    REAL zmax(klon), zw, zz, ztva(klon, klev), zzz
     67
     68    REAL zlev(klon, klev + 1), zlay(klon, klev)
     69    REAL zh(klon, klev), zdhadj(klon, klev)
     70    REAL ztv(klon, klev)
     71    REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
     72    REAL wh(klon, klev + 1)
     73    REAL wu(klon, klev + 1), wv(klon, klev + 1), wo(klon, klev + 1)
     74    REAL zla(klon, klev + 1)
     75    REAL zwa(klon, klev + 1)
     76    REAL zld(klon, klev + 1)
     77    REAL zwd(klon, klev + 1)
     78    REAL zsortie(klon, klev)
     79    REAL zva(klon, klev)
     80    REAL zua(klon, klev)
     81    REAL zoa(klon, klev)
     82
     83    REAL zha(klon, klev)
     84    REAL wa_moy(klon, klev + 1)
     85    REAL fracc(klon, klev + 1)
     86    REAL zf, zf2
     87    REAL thetath2(klon, klev), wth2(klon, klev)
     88    ! common/comtherm/thetath2,wth2
     89
     90    REAL count_time
     91
     92    LOGICAL sorties
     93    REAL rho(klon, klev), rhobarz(klon, klev + 1), masse(klon, klev)
     94    REAL zpspsk(klon, klev)
     95
     96    REAL wmax(klon, klev), wmaxa(klon)
     97
     98    REAL wa(klon, klev, klev + 1)
     99    REAL wd(klon, klev + 1)
     100    REAL larg_part(klon, klev, klev + 1)
     101    REAL fracd(klon, klev + 1)
     102    REAL xxx(klon, klev + 1)
     103    REAL larg_cons(klon, klev + 1)
     104    REAL larg_detr(klon, klev + 1)
     105    REAL fm0(klon, klev + 1), entr0(klon, klev), detr(klon, klev)
     106    REAL pu_therm(klon, klev), pv_therm(klon, klev)
     107    REAL fm(klon, klev + 1), entr(klon, klev)
     108    REAL fmc(klon, klev + 1)
     109
     110    CHARACTER (LEN = 2) :: str2
     111    CHARACTER (LEN = 10) :: str10
     112
     113    CHARACTER (LEN = 20) :: modname = 'thermcell2002'
     114    CHARACTER (LEN = 80) :: abort_message
     115
     116    LOGICAL vtest(klon), down
     117
     118    INTEGER ncorrec, ll
     119    SAVE ncorrec
     120    DATA ncorrec/0/
     121    !$OMP THREADPRIVATE(ncorrec)
     122
     123
     124    ! -----------------------------------------------------------------------
     125    ! initialisation:
     126    ! ---------------
     127
     128    sorties = .TRUE.
     129    IF (ngrid/=klon) THEN
     130      PRINT *
     131      PRINT *, 'STOP dans convadj'
     132      PRINT *, 'ngrid    =', ngrid
     133      PRINT *, 'klon  =', klon
     134    END IF
     135
     136    ! -----------------------------------------------------------------------
     137    ! incrementation eventuelle de tendances precedentes:
     138    ! ---------------------------------------------------
     139
     140    ! PRINT*,'0 OK convect8'
     141
     142    DO l = 1, nlay
     143      DO ig = 1, ngrid
     144        zpspsk(ig, l) = (pplay(ig, l) / pplev(ig, 1))**rkappa
     145        zh(ig, l) = pt(ig, l) / zpspsk(ig, l)
     146        zu(ig, l) = pu(ig, l)
     147        zv(ig, l) = pv(ig, l)
     148        zo(ig, l) = po(ig, l)
     149        ztv(ig, l) = zh(ig, l) * (1. + 0.61 * zo(ig, l))
     150      END DO
     151    END DO
     152
     153    ! PRINT*,'1 OK convect8'
     154    ! --------------------
     155
     156
     157    ! + + + + + + + + + + +
     158
     159
     160    ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
     161    ! wh,wt,wo ...
     162
     163    ! + + + + + + + + + + +  zh,zu,zv,zo,rho
     164
     165
     166    ! --------------------   zlev(1)
     167    ! \\\\\\\\\\\\\\\\\\\\
     168
     169
     170
     171    ! -----------------------------------------------------------------------
     172    ! Calcul des altitudes des couches
     173    ! -----------------------------------------------------------------------
     174
     175    IF (debut) THEN
     176      flagdq = (iflag_thermals - 1000) / 100
     177      dvdq = (iflag_thermals - (1000 + flagdq * 100)) / 10
     178      IF (flagdq==2) dqimpl = -1
     179      IF (flagdq==3) dqimpl = 1
     180      debut = .FALSE.
     181    END IF
     182    PRINT *, 'TH flag th ', iflag_thermals, flagdq, dvdq, dqimpl
     183
     184    DO l = 2, nlay
     185      DO ig = 1, ngrid
     186        zlev(ig, l) = 0.5 * (pphi(ig, l) + pphi(ig, l - 1)) / rg
     187      END DO
     188    END DO
     189    DO ig = 1, ngrid
     190      zlev(ig, 1) = 0.
     191      zlev(ig, nlay + 1) = (2. * pphi(ig, klev) - pphi(ig, klev - 1)) / rg
     192    END DO
     193    DO l = 1, nlay
     194      DO ig = 1, ngrid
     195        zlay(ig, l) = pphi(ig, l) / rg
     196      END DO
     197    END DO
     198
     199    ! PRINT*,'2 OK convect8'
     200    ! -----------------------------------------------------------------------
     201    ! Calcul des densites
     202    ! -----------------------------------------------------------------------
     203
     204    DO l = 1, nlay
     205      DO ig = 1, ngrid
     206        rho(ig, l) = pplay(ig, l) / (zpspsk(ig, l) * rd * zh(ig, l))
     207      END DO
     208    END DO
     209
     210    DO l = 2, nlay
     211      DO ig = 1, ngrid
     212        rhobarz(ig, l) = 0.5 * (rho(ig, l) + rho(ig, l - 1))
     213      END DO
     214    END DO
     215
     216    DO k = 1, nlay
     217      DO l = 1, nlay + 1
     218        DO ig = 1, ngrid
     219          wa(ig, k, l) = 0.
     220        END DO
     221      END DO
     222    END DO
     223
     224    ! PRINT*,'3 OK convect8'
     225    ! ------------------------------------------------------------------
     226    ! Calcul de w2, quarre de w a partir de la cape
     227    ! a partir de w2, on calcule wa, vitesse de l'ascendance
     228
     229    ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
     230    ! w2 est stoke dans wa
     231
     232    ! ATTENTION: dans convect8, on n'utilise le calcule des wa
     233    ! independants par couches que pour calculer l'entrainement
     234    ! a la base et la hauteur max de l'ascendance.
     235
     236    ! Indicages:
     237    ! l'ascendance provenant du niveau k traverse l'interface l avec
     238    ! une vitesse wa(k,l).
     239
     240    ! --------------------
     241
     242    ! + + + + + + + + + +
     243
     244    ! wa(k,l)   ----       --------------------    l
     245    ! /\
     246    ! /||\       + + + + + + + + + +
     247    ! ||
     248    ! ||        --------------------
     249    ! ||
     250    ! ||        + + + + + + + + + +
     251    ! ||
     252    ! ||        --------------------
     253    ! ||__
     254    ! |___      + + + + + + + + + +     k
     255
     256    ! --------------------
     257
     258
     259
     260    ! ------------------------------------------------------------------
     261
     262    DO k = 1, nlay - 1
     263      DO ig = 1, ngrid
     264        wa(ig, k, k) = 0.
     265        wa(ig, k, k + 1) = 2. * rg * (ztv(ig, k) - ztv(ig, k + 1)) / ztv(ig, k + 1) * &
     266                (zlev(ig, k + 1) - zlev(ig, k))
     267      END DO
     268      DO l = k + 1, nlay - 1
     269        DO ig = 1, ngrid
     270          wa(ig, k, l + 1) = wa(ig, k, l) + 2. * rg * (ztv(ig, k) - ztv(ig, l)) / ztv(ig, l &
     271                  ) * (zlev(ig, l + 1) - zlev(ig, l))
     272        END DO
     273      END DO
     274      DO ig = 1, ngrid
     275        wa(ig, k, nlay + 1) = 0.
     276      END DO
     277    END DO
     278
     279    ! PRINT*,'4 OK convect8'
     280    ! Calcul de la couche correspondant a la hauteur du thermique
     281    DO k = 1, nlay - 1
     282      DO ig = 1, ngrid
     283        lmax(ig, k) = k
     284      END DO
     285      DO l = nlay, k + 1, -1
     286        DO ig = 1, ngrid
     287          IF (wa(ig, k, l)<=1.E-10) lmax(ig, k) = l - 1
     288        END DO
     289      END DO
     290    END DO
     291
     292    ! PRINT*,'5 OK convect8'
     293    ! Calcule du w max du thermique
     294    DO k = 1, nlay
     295      DO ig = 1, ngrid
     296        wmax(ig, k) = 0.
     297      END DO
     298    END DO
     299
     300    DO k = 1, nlay - 1
     301      DO l = k, nlay
     302        DO ig = 1, ngrid
     303          IF (l<=lmax(ig, k)) THEN
     304            wa(ig, k, l) = sqrt(wa(ig, k, l))
     305            wmax(ig, k) = max(wmax(ig, k), wa(ig, k, l))
     306          ELSE
     307            wa(ig, k, l) = 0.
     308          END IF
     309        END DO
     310      END DO
     311    END DO
     312
     313    DO k = 1, nlay - 1
     314      DO ig = 1, ngrid
     315        pu_therm(ig, k) = sqrt(wmax(ig, k))
     316        pv_therm(ig, k) = sqrt(wmax(ig, k))
     317      END DO
     318    END DO
     319
     320    ! PRINT*,'6 OK convect8'
     321    ! Longueur caracteristique correspondant a la hauteur des thermiques.
     322    DO ig = 1, ngrid
     323      zmax(ig) = 500.
     324    END DO
     325    ! PRINT*,'LMAX LMAX LMAX '
     326    DO k = 1, nlay - 1
     327      DO ig = 1, ngrid
     328        zmax(ig) = max(zmax(ig), zlev(ig, lmax(ig, k)) - zlev(ig, k))
     329      END DO
     330      ! PRINT*,k,lmax(1,k)
     331    END DO
     332    ! PRINT*,'ZMAX ZMAX ZMAX ',zmax
     333    ! CALL dump2d(iim,jjm-1,zmax(2:ngrid-1),'ZMAX      ')
     334
     335    ! PRINT*,'OKl336'
     336    ! Calcul de l'entrainement.
     337    ! Le rapport d'aspect relie la largeur de l'ascendance a l'epaisseur
     338    ! de la couche d'alimentation en partant du principe que la vitesse
     339    ! maximum dans l'ascendance est la vitesse d'entrainement horizontale.
     340    DO k = 1, nlay
     341      DO ig = 1, ngrid
     342        zzz = rho(ig, k) * wmax(ig, k) * (zlev(ig, k + 1) - zlev(ig, k)) / &
     343                (zmax(ig) * r_aspect)
     344        IF (w2di==2) THEN
     345          entr(ig, k) = entr(ig, k) + ptimestep * (zzz - entr(ig, k)) / tho
     346        ELSE
     347          entr(ig, k) = zzz
     348        END IF
     349        ztva(ig, k) = ztv(ig, k)
     350      END DO
     351    END DO
     352
     353
     354    ! PRINT*,'7 OK convect8'
     355    DO k = 1, klev + 1
     356      DO ig = 1, ngrid
     357        zw2(ig, k) = 0.
     358        fmc(ig, k) = 0.
     359        larg_cons(ig, k) = 0.
     360        larg_detr(ig, k) = 0.
     361        wa_moy(ig, k) = 0.
     362      END DO
     363    END DO
     364
     365    ! PRINT*,'8 OK convect8'
     366    DO ig = 1, ngrid
     367      lmaxa(ig) = 1
     368      lmix(ig) = 1
     369      wmaxa(ig) = 0.
     370    END DO
     371
     372
     373    ! PRINT*,'OKl372'
     374    DO l = 1, nlay - 2
     375      DO ig = 1, ngrid
     376        ! if (zw2(ig,l).lt.1.e-10.AND.ztv(ig,l).gt.ztv(ig,l+1)) THEN
     377        ! PRINT*,'COUCOU ',l,zw2(ig,l),ztv(ig,l),ztv(ig,l+1)
     378        IF (zw2(ig, l)<1.E-10 .AND. ztv(ig, l)>ztv(ig, l + 1) .AND. &
     379                entr(ig, l)>1.E-10) THEN
     380          ! PRINT*,'COUCOU cas 1'
     381          ! Initialisation de l'ascendance
     382          ! lmix(ig)=1
     383          ztva(ig, l) = ztv(ig, l)
     384          fmc(ig, l) = 0.
     385          fmc(ig, l + 1) = entr(ig, l)
     386          zw2(ig, l) = 0.
     387          ! if (.NOT.ztv(ig,l+1).gt.150.) THEN
     388          ! PRINT*,'ig,l+1,ztv(ig,l+1)'
     389          ! PRINT*, ig,l+1,ztv(ig,l+1)
     390          ! END IF
     391          zw2(ig, l + 1) = 2. * rg * (ztv(ig, l) - ztv(ig, l + 1)) / ztv(ig, l + 1) * &
     392                  (zlev(ig, l + 1) - zlev(ig, l))
     393          larg_detr(ig, l) = 0.
     394        ELSE IF (zw2(ig, l)>=1.E-10 .AND. fmc(ig, l) + entr(ig, l)>1.E-10) THEN
     395          ! Incrementation...
     396          fmc(ig, l + 1) = fmc(ig, l) + entr(ig, l)
     397          ! if (.NOT.fmc(ig,l+1).gt.1.e-15) THEN
     398          ! PRINT*,'ig,l+1,fmc(ig,l+1)'
     399          ! PRINT*, ig,l+1,fmc(ig,l+1)
     400          ! PRINT*,'Fmc ',(fmc(ig,ll),ll=1,klev+1)
     401          ! PRINT*,'W2 ',(zw2(ig,ll),ll=1,klev+1)
     402          ! PRINT*,'Tv ',(ztv(ig,ll),ll=1,klev)
     403          ! PRINT*,'Entr ',(entr(ig,ll),ll=1,klev)
     404          ! END IF
     405          ztva(ig, l) = (fmc(ig, l) * ztva(ig, l - 1) + entr(ig, l) * ztv(ig, l)) / &
     406                  fmc(ig, l + 1)
     407          ! mise a jour de la vitesse ascendante (l'air entraine de la couche
     408          ! consideree commence avec une vitesse nulle).
     409          zw2(ig, l + 1) = zw2(ig, l) * (fmc(ig, l) / fmc(ig, l + 1))**2 + &
     410                  2. * rg * (ztva(ig, l) - ztv(ig, l)) / ztv(ig, l) * (zlev(ig, l + 1) - zlev(ig, l))
     411        END IF
     412        IF (zw2(ig, l + 1)<0.) THEN
     413          zw2(ig, l + 1) = 0.
     414          lmaxa(ig) = l
     415        ELSE
     416          wa_moy(ig, l + 1) = sqrt(zw2(ig, l + 1))
     417        END IF
     418        IF (wa_moy(ig, l + 1)>wmaxa(ig)) THEN
     419          ! lmix est le niveau de la couche ou w (wa_moy) est maximum
     420          lmix(ig) = l + 1
     421          wmaxa(ig) = wa_moy(ig, l + 1)
     422        END IF
     423        ! PRINT*,'COUCOU cas 2 LMIX=',lmix(ig),wa_moy(ig,l+1),wmaxa(ig)
     424      END DO
     425    END DO
     426
     427    ! PRINT*,'9 OK convect8'
     428    ! PRINT*,'WA1 ',wa_moy
     429
     430    ! determination de l'indice du debut de la mixed layer ou w decroit
     431
     432    ! calcul de la largeur de chaque ascendance dans le cas conservatif.
     433    ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
     434    ! d'une couche est égale à la hauteur de la couche alimentante.
     435    ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
     436    ! de la vitesse d'entrainement horizontal dans la couche alimentante.
     437
     438    ! PRINT*,'OKl439'
     439    DO l = 2, nlay
     440      DO ig = 1, ngrid
     441        IF (l<=lmaxa(ig)) THEN
     442          zw = max(wa_moy(ig, l), 1.E-10)
     443          larg_cons(ig, l) = zmax(ig) * r_aspect * fmc(ig, l) / (rhobarz(ig, l) * zw)
     444        END IF
     445      END DO
     446    END DO
     447
     448    DO l = 2, nlay
     449      DO ig = 1, ngrid
     450        IF (l<=lmaxa(ig)) THEN
     451          ! if (idetr.EQ.0) THEN
     452          ! cette option est finalement en dur.
     453          larg_detr(ig, l) = sqrt(l_mix * zlev(ig, l))
     454          ! ELSE IF (idetr.EQ.1) THEN
     455          ! larg_detr(ig,l)=larg_cons(ig,l)
     456          ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
     457          ! ELSE IF (idetr.EQ.2) THEN
     458          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     459          ! s            *sqrt(wa_moy(ig,l))
     460          ! ELSE IF (idetr.EQ.4) THEN
     461          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     462          ! s            *wa_moy(ig,l)
     463          ! END IF
     464        END IF
     465      END DO
     466    END DO
     467
     468    ! PRINT*,'10 OK convect8'
     469    ! PRINT*,'WA2 ',wa_moy
     470    ! calcul de la fraction de la maille concernée par l'ascendance en tenant
     471    ! compte de l'epluchage du thermique.
     472
     473    DO l = 2, nlay
     474      DO ig = 1, ngrid
     475        IF (larg_cons(ig, l)>1.) THEN
     476          ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
     477          fraca(ig, l) = (larg_cons(ig, l) - larg_detr(ig, l)) / (r_aspect * zmax(ig))
     478          IF (l>lmix(ig)) THEN
     479            xxx(ig, l) = (lmaxa(ig) + 1. - l) / (lmaxa(ig) + 1. - lmix(ig))
     480            IF (idetr==0) THEN
     481              fraca(ig, l) = fraca(ig, lmix(ig))
     482            ELSE IF (idetr==1) THEN
     483              fraca(ig, l) = fraca(ig, lmix(ig)) * xxx(ig, l)
     484            ELSE IF (idetr==2) THEN
     485              fraca(ig, l) = fraca(ig, lmix(ig)) * (1. - (1. - xxx(ig, l))**2)
     486            ELSE
     487              fraca(ig, l) = fraca(ig, lmix(ig)) * xxx(ig, l)**2
     488            END IF
     489          END IF
     490          ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
     491          fraca(ig, l) = max(fraca(ig, l), 0.)
     492          fraca(ig, l) = min(fraca(ig, l), 0.5)
     493          fracd(ig, l) = 1. - fraca(ig, l)
     494          fracc(ig, l) = larg_cons(ig, l) / (r_aspect * zmax(ig))
     495        ELSE
     496          ! wa_moy(ig,l)=0.
     497          fraca(ig, l) = 0.
     498          fracc(ig, l) = 0.
     499          fracd(ig, l) = 1.
     500        END IF
     501      END DO
     502    END DO
     503
     504    ! PRINT*,'11 OK convect8'
     505    ! PRINT*,'Ea3 ',wa_moy
     506    ! ------------------------------------------------------------------
     507    ! Calcul de fracd, wd
     508    ! somme wa - wd = 0
     509    ! ------------------------------------------------------------------
     510
     511    DO ig = 1, ngrid
     512      fm(ig, 1) = 0.
     513      fm(ig, nlay + 1) = 0.
     514    END DO
     515
     516    DO l = 2, nlay
     517      DO ig = 1, ngrid
     518        fm(ig, l) = fraca(ig, l) * wa_moy(ig, l) * rhobarz(ig, l)
     519      END DO
     520      DO ig = 1, ngrid
     521        IF (fracd(ig, l)<0.1) THEN
     522          abort_message = 'fracd trop petit'
     523          CALL abort_physic(modname, abort_message, 1)
     524        ELSE
     525          ! vitesse descendante "diagnostique"
     526          wd(ig, l) = fm(ig, l) / (fracd(ig, l) * rhobarz(ig, l))
     527        END IF
     528      END DO
     529    END DO
     530
     531    DO l = 1, nlay
     532      DO ig = 1, ngrid
     533        ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
     534        masse(ig, l) = (pplev(ig, l) - pplev(ig, l + 1)) / rg
     535      END DO
     536    END DO
     537
     538    ! PRINT*,'12 OK convect8'
     539    ! PRINT*,'WA4 ',wa_moy
     540    ! c------------------------------------------------------------------
     541    ! calcul du transport vertical
     542    ! ------------------------------------------------------------------
     543
     544    GO TO 4444
     545    ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
     546    DO l = 2, nlay - 1
     547      DO ig = 1, ngrid
     548        IF (fm(ig, l + 1) * ptimestep>masse(ig, l) .AND. fm(ig, l + 1) * ptimestep>masse(&
     549                ig, l + 1)) THEN
     550          ! PRINT*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
     551          ! s         ,fm(ig,l+1)*ptimestep
     552          ! s         ,'   M=',masse(ig,l),masse(ig,l+1)
     553        END IF
     554      END DO
     555    END DO
     556
     557    DO l = 1, nlay
     558      DO ig = 1, ngrid
     559        IF (entr(ig, l) * ptimestep>masse(ig, l)) THEN
     560          ! PRINT*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
     561          ! s         ,entr(ig,l)*ptimestep
     562          ! s         ,'   M=',masse(ig,l)
     563        END IF
     564      END DO
     565    END DO
     566
     567    DO l = 1, nlay
     568      DO ig = 1, ngrid
     569        IF (.NOT. fm(ig, l)>=0. .OR. .NOT. fm(ig, l)<=10.) THEN
     570          ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
     571          ! s         ,'   FM=',fm(ig,l)
     572        END IF
     573        IF (.NOT. masse(ig, l)>=1.E-10 .OR. .NOT. masse(ig, l)<=1.E4) THEN
     574          ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
     575          ! s         ,'   M=',masse(ig,l)
     576          ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
     577          ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
     578          ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
     579          ! s                ,zlev(ig,l+1),zlev(ig,l)
     580          ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
     581          ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
     582        END IF
     583        IF (.NOT. entr(ig, l)>=0. .OR. .NOT. entr(ig, l)<=10.) THEN
     584          ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
     585          ! s         ,'   E=',entr(ig,l)
     586        END IF
     587      END DO
     588    END DO
     589
     590    4444 CONTINUE
     591    ! PRINT*,'OK 444 '
     592
     593    IF (w2di==1) THEN
     594      fm0 = fm0 + ptimestep * (fm - fm0) / tho
     595      entr0 = entr0 + ptimestep * (entr - entr0) / tho
     596    ELSE
     597      fm0 = fm
     598      entr0 = entr
     599    END IF
     600
     601    IF (flagdq==0) THEN
     602      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, &
     603              zha)
     604      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, &
     605              zoa)
     606      PRINT *, 'THERMALS OPT 1'
     607    ELSE IF (flagdq==1) THEN
     608      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
     609              zdhadj, zha)
     610      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
     611              pdoadj, zoa)
     612      PRINT *, 'THERMALS OPT 2'
     613    ELSE
     614      CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zh, &
     615              zdhadj, zha, lev_out)
     616      CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zo, &
     617              pdoadj, zoa, lev_out)
     618      PRINT *, 'THERMALS OPT 3', dqimpl
     619    END IF
     620
     621    PRINT *, 'TH VENT ', dvdq
     622    IF (dvdq==0) THEN
     623      ! PRINT*,'TH VENT OK ',dvdq
     624      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
     625              zua)
     626      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
     627              zva)
     628    ELSE IF (dvdq==1) THEN
     629      CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
     630              zu, zv, pduadj, pdvadj, zua, zva)
     631    ELSE IF (dvdq==2) THEN
     632      CALL thermcell_dv2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, &
     633              zmax, zu, zv, pduadj, pdvadj, zua, zva, lev_out)
     634    ELSE IF (dvdq==3) THEN
     635      CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zu, &
     636              pduadj, zua, lev_out)
     637      CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zv, &
     638              pdvadj, zva, lev_out)
     639    END IF
     640
     641    ! CALL writefield_phy('duadj',pduadj,klev)
     642
     643    DO l = 1, nlay
     644      DO ig = 1, ngrid
     645        zf = 0.5 * (fracc(ig, l) + fracc(ig, l + 1))
     646        zf2 = zf / (1. - zf)
     647        thetath2(ig, l) = zf2 * (zha(ig, l) - zh(ig, l))**2
     648        wth2(ig, l) = zf2 * (0.5 * (wa_moy(ig, l) + wa_moy(ig, l + 1)))**2
     649      END DO
     650    END DO
     651
     652
     653
     654    ! PRINT*,'13 OK convect8'
     655    ! PRINT*,'WA5 ',wa_moy
     656    DO l = 1, nlay
     657      DO ig = 1, ngrid
     658        pdtadj(ig, l) = zdhadj(ig, l) * zpspsk(ig, l)
     659      END DO
     660    END DO
     661
     662
     663    ! do l=1,nlay
     664    ! do ig=1,ngrid
     665    ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
     666    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     667    ! s         ,'   pdtadj=',pdtadj(ig,l)
     668    ! END IF
     669    ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
     670    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     671    ! s         ,'   pdoadj=',pdoadj(ig,l)
     672    ! END IF
     673    ! enddo
     674    ! enddo
     675
     676    ! PRINT*,'14 OK convect8'
     677    ! ------------------------------------------------------------------
     678    ! Calculs pour les sorties
     679    ! ------------------------------------------------------------------
     680
     681    IF (sorties) THEN
     682      DO l = 1, nlay
     683        DO ig = 1, ngrid
     684          zla(ig, l) = (1. - fracd(ig, l)) * zmax(ig)
     685          zld(ig, l) = fracd(ig, l) * zmax(ig)
     686          IF (1. - fracd(ig, l)>1.E-10) zwa(ig, l) = wd(ig, l) * fracd(ig, l) / &
     687                  (1. - fracd(ig, l))
     688        END DO
     689      END DO
     690
     691      DO l = 1, nlay
     692        DO ig = 1, ngrid
     693          detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l + 1)
     694          IF (detr(ig, l)<0.) THEN
     695            entr(ig, l) = entr(ig, l) - detr(ig, l)
     696            detr(ig, l) = 0.
     697            ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
     698          END IF
     699        END DO
     700      END DO
     701    END IF
     702
     703    ! PRINT*,'15 OK convect8'
     704
     705
     706    ! IF(wa_moy(1,4).gt.1.e-10) stop
     707
     708    ! PRINT*,'19 OK convect8'
     709
     710  END SUBROUTINE thermcell_2002
     711
     712  SUBROUTINE thermcell_cld(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, &
     713          debut, pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0, zqla, &
     714          lmax, zmax_sec, wmax_sec, zw_sec, lmix_sec, ratqscth, ratqsdiff & ! s
     715          ! ,pu_therm,pv_therm
     716          , r_aspect, l_mix, w2di, tho)
     717
     718    USE dimphy
     719    IMPLICIT NONE
     720
     721    ! =======================================================================
     722
     723    ! Calcul du transport verticale dans la couche limite en presence
     724    ! de "thermiques" explicitement representes
     725
     726    ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
     727
     728    ! le thermique est supposé homogène et dissipé par mélange avec
     729    ! son environnement. la longueur l_mix contrôle l'efficacité du
     730    ! mélange
     731
     732    ! Le calcul du transport des différentes espèces se fait en prenant
     733    ! en compte:
     734    ! 1. un flux de masse montant
     735    ! 2. un flux de masse descendant
     736    ! 3. un entrainement
     737    ! 4. un detrainement
     738
     739    ! =======================================================================
     740
     741    ! -----------------------------------------------------------------------
     742    ! declarations:
     743    ! -------------
     744
     745    include "YOMCST.h"
     746    include "YOETHF.h"
     747    include "FCTTRE.h"
     748
     749    ! arguments:
     750    ! ----------
     751
     752    INTEGER ngrid, nlay, w2di
     753    REAL tho
     754    REAL ptimestep, l_mix, r_aspect
     755    REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
     756    REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
     757    REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
     758    REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
     759    REAL pplay(ngrid, nlay), pplev(ngrid, nlay + 1)
     760    REAL pphi(ngrid, nlay)
     761
     762    INTEGER idetr
     763    SAVE idetr
     764    DATA idetr/3/
     765    !$OMP THREADPRIVATE(idetr)
     766
     767    ! local:
     768    ! ------
     769
     770    INTEGER ig, k, l, lmaxa(klon), lmix(klon)
     771    REAL zsortie1d(klon)
     772    ! CR: on remplace lmax(klon,klev+1)
     773    INTEGER lmax(klon), lmin(klon), lentr(klon)
     774    REAL linter(klon)
     775    REAL zmix(klon), fracazmix(klon)
     776    REAL alpha
     777    SAVE alpha
     778    DATA alpha/1./
     779    !$OMP THREADPRIVATE(alpha)
     780
     781    ! RC
     782    REAL zmax(klon), zw, zz, zw2(klon, klev + 1), ztva(klon, klev), zzz
     783    REAL zmax_sec(klon)
     784    REAL zmax_sec2(klon)
     785    REAL zw_sec(klon, klev + 1)
     786    INTEGER lmix_sec(klon)
     787    REAL w_est(klon, klev + 1)
     788    ! on garde le zmax du pas de temps precedent
     789    ! real zmax0(klon)
     790    ! save zmax0
     791    ! real zmix0(klon)
     792    ! save zmix0
     793    REAL, SAVE, ALLOCATABLE :: zmax0(:), zmix0(:)
     794    !$OMP THREADPRIVATE(zmax0, zmix0)
     795
     796    REAL zlev(klon, klev + 1), zlay(klon, klev)
     797    REAL deltaz(klon, klev)
     798    REAL zh(klon, klev), zdhadj(klon, klev)
     799    REAL zthl(klon, klev), zdthladj(klon, klev)
     800    REAL ztv(klon, klev)
     801    REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
     802    REAL zl(klon, klev)
     803    REAL wh(klon, klev + 1)
     804    REAL wu(klon, klev + 1), wv(klon, klev + 1), wo(klon, klev + 1)
     805    REAL zla(klon, klev + 1)
     806    REAL zwa(klon, klev + 1)
     807    REAL zld(klon, klev + 1)
     808    REAL zwd(klon, klev + 1)
     809    REAL zsortie(klon, klev)
     810    REAL zva(klon, klev)
     811    REAL zua(klon, klev)
     812    REAL zoa(klon, klev)
     813
     814    REAL zta(klon, klev)
     815    REAL zha(klon, klev)
     816    REAL wa_moy(klon, klev + 1)
     817    REAL fraca(klon, klev + 1)
     818    REAL fracc(klon, klev + 1)
     819    REAL zf, zf2
     820    REAL thetath2(klon, klev), wth2(klon, klev), wth3(klon, klev)
     821    REAL q2(klon, klev)
     822    REAL dtheta(klon, klev)
     823    ! common/comtherm/thetath2,wth2
     824
     825    REAL ratqscth(klon, klev)
     826    REAL sum
     827    REAL sumdiff
     828    REAL ratqsdiff(klon, klev)
     829    REAL count_time
     830    INTEGER ialt
     831
     832    LOGICAL sorties
     833    REAL rho(klon, klev), rhobarz(klon, klev + 1), masse(klon, klev)
     834    REAL zpspsk(klon, klev)
     835
     836    ! real wmax(klon,klev),wmaxa(klon)
     837    REAL wmax(klon), wmaxa(klon)
     838    REAL wmax_sec(klon)
     839    REAL wmax_sec2(klon)
     840    REAL wa(klon, klev, klev + 1)
     841    REAL wd(klon, klev + 1)
     842    REAL larg_part(klon, klev, klev + 1)
     843    REAL fracd(klon, klev + 1)
     844    REAL xxx(klon, klev + 1)
     845    REAL larg_cons(klon, klev + 1)
     846    REAL larg_detr(klon, klev + 1)
     847    REAL fm0(klon, klev + 1), entr0(klon, klev), detr(klon, klev)
     848    REAL massetot(klon, klev)
     849    REAL detr0(klon, klev)
     850    REAL alim0(klon, klev)
     851    REAL pu_therm(klon, klev), pv_therm(klon, klev)
     852    REAL fm(klon, klev + 1), entr(klon, klev)
     853    REAL fmc(klon, klev + 1)
     854
     855    REAL zcor, zdelta, zcvm5, qlbef
     856    REAL tbef(klon), qsatbef(klon)
     857    REAL dqsat_dt, dt, num, denom
     858    REAL reps, rlvcp, ddt0
     859    REAL ztla(klon, klev), zqla(klon, klev), zqta(klon, klev)
     860    ! CR niveau de condensation
     861    REAL nivcon(klon)
     862    REAL zcon(klon)
     863    REAL zqsat(klon, klev)
     864    REAL zqsatth(klon, klev)
     865    PARAMETER (ddt0 = .01)
     866
     867
     868    ! CR:nouvelles variables
     869    REAL f_star(klon, klev + 1), entr_star(klon, klev)
     870    REAL detr_star(klon, klev)
     871    REAL alim_star_tot(klon), alim_star2(klon)
     872    REAL entr_star_tot(klon)
     873    REAL detr_star_tot(klon)
     874    REAL alim_star(klon, klev)
     875    REAL alim(klon, klev)
     876    REAL nu(klon, klev)
     877    REAL nu_e(klon, klev)
     878    REAL nu_min
     879    REAL nu_max
     880    REAL nu_r
     881    REAL f(klon)
     882    ! real f(klon), f0(klon)
     883    ! save f0
     884    REAL, SAVE, ALLOCATABLE :: f0(:)
     885    !$OMP THREADPRIVATE(f0)
     886
     887    REAL f_old
     888    REAL zlevinter(klon)
     889    LOGICAL, SAVE :: first = .TRUE.
     890    !$OMP THREADPRIVATE(first)
     891    ! data first /.FALSE./
     892    ! save first
     893    LOGICAL nuage
     894    ! save nuage
     895    LOGICAL boucle
     896    LOGICAL therm
     897    LOGICAL debut
     898    LOGICAL rale
     899    INTEGER test(klon)
     900    INTEGER signe_zw2
     901    ! RC
     902
     903    CHARACTER *2 str2
     904    CHARACTER *10 str10
     905
     906    CHARACTER (LEN = 20) :: modname = 'thermcell_cld'
     907    CHARACTER (LEN = 80) :: abort_message
     908
     909    LOGICAL vtest(klon), down
     910    LOGICAL zsat(klon)
     911
     912    INTEGER ncorrec, ll
     913    SAVE ncorrec
     914    DATA ncorrec/0/
     915    !$OMP THREADPRIVATE(ncorrec)
     916
     917
     918
     919    ! -----------------------------------------------------------------------
     920    ! initialisation:
     921    ! ---------------
     922
     923    IF (first) THEN
     924      ALLOCATE (zmix0(klon))
     925      ALLOCATE (zmax0(klon))
     926      ALLOCATE (f0(klon))
     927      first = .FALSE.
     928    END IF
     929
     930    sorties = .FALSE.
     931    ! PRINT*,'NOUVEAU DETR PLUIE '
     932    IF (ngrid/=klon) THEN
     933      PRINT *
     934      PRINT *, 'STOP dans convadj'
     935      PRINT *, 'ngrid    =', ngrid
     936      PRINT *, 'klon  =', klon
     937    END IF
     938
     939    ! Initialisation
     940    rlvcp = rlvtt / rcpd
     941    reps = rd / rv
     942    ! initialisations de zqsat
     943    DO ll = 1, nlay
     944      DO ig = 1, ngrid
     945        zqsat(ig, ll) = 0.
     946        zqsatth(ig, ll) = 0.
     947      END DO
     948    END DO
     949
     950    ! on met le first a true pour le premier passage de la journée
     951    DO ig = 1, klon
     952      test(ig) = 0
     953    END DO
     954    IF (debut) THEN
     955      DO ig = 1, klon
     956        test(ig) = 1
     957        f0(ig) = 0.
     958        zmax0(ig) = 0.
     959      END DO
     960    END IF
     961    DO ig = 1, klon
     962      IF ((.NOT. debut) .AND. (f0(ig)<1.E-10)) THEN
     963        test(ig) = 1
     964      END IF
     965    END DO
     966    ! do ig=1,klon
     967    ! PRINT*,'test(ig)',test(ig),zmax0(ig)
     968    ! enddo
     969    nuage = .FALSE.
     970    ! -----------------------------------------------------------------------
     971    ! AM Calcul de T,q,ql a partir de Tl et qT
     972    ! ---------------------------------------------------
     973
     974    ! Pr Tprec=Tl calcul de qsat
     975    ! Si qsat>qT T=Tl, q=qT
     976    ! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt)
     977    ! On cherche DDT < DDT0
     978
     979    ! defaut
     980    DO ll = 1, nlay
     981      DO ig = 1, ngrid
     982        zo(ig, ll) = po(ig, ll)
     983        zl(ig, ll) = 0.
     984        zh(ig, ll) = pt(ig, ll)
     985      END DO
     986    END DO
     987    DO ig = 1, ngrid
     988      zsat(ig) = .FALSE.
     989    END DO
     990
     991    DO ll = 1, nlay
     992      ! les points insatures sont definitifs
     993      DO ig = 1, ngrid
     994        tbef(ig) = pt(ig, ll)
     995        zdelta = max(0., sign(1., rtt - tbef(ig)))
     996        qsatbef(ig) = r2es * foeew(tbef(ig), zdelta) / pplev(ig, ll)
     997        qsatbef(ig) = min(0.5, qsatbef(ig))
     998        zcor = 1. / (1. - retv * qsatbef(ig))
     999        qsatbef(ig) = qsatbef(ig) * zcor
     1000        zsat(ig) = (max(0., po(ig, ll) - qsatbef(ig))>1.E-10)
     1001      END DO
     1002
     1003      DO ig = 1, ngrid
     1004        IF (zsat(ig) .AND. (1==1)) THEN
     1005          qlbef = max(0., po(ig, ll) - qsatbef(ig))
     1006          ! si sature: ql est surestime, d'ou la sous-relax
     1007          dt = 0.5 * rlvcp * qlbef
     1008          ! WRITE(18,*) 'DT0=',DT
     1009          ! on pourra enchainer 2 ou 3 calculs sans Do while
     1010          DO WHILE (abs(dt)>ddt0)
     1011            ! il faut verifier si c,a conserve quand on repasse en insature ...
     1012            tbef(ig) = tbef(ig) + dt
     1013            zdelta = max(0., sign(1., rtt - tbef(ig)))
     1014            qsatbef(ig) = r2es * foeew(tbef(ig), zdelta) / pplev(ig, ll)
     1015            qsatbef(ig) = min(0.5, qsatbef(ig))
     1016            zcor = 1. / (1. - retv * qsatbef(ig))
     1017            qsatbef(ig) = qsatbef(ig) * zcor
     1018            ! on veut le signe de qlbef
     1019            qlbef = po(ig, ll) - qsatbef(ig)
     1020            zdelta = max(0., sign(1., rtt - tbef(ig)))
     1021            zcvm5 = r5les * (1. - zdelta) + r5ies * zdelta
     1022            zcor = 1. / (1. - retv * qsatbef(ig))
     1023            dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor)
     1024            num = -tbef(ig) + pt(ig, ll) + rlvcp * qlbef
     1025            denom = 1. + rlvcp * dqsat_dt
     1026            IF (denom<1.E-10) THEN
     1027              PRINT *, 'pb denom'
     1028            END IF
     1029            dt = num / denom
     1030          END DO
     1031          ! on ecrit de maniere conservative (sat ou non)
     1032          zl(ig, ll) = max(0., qlbef)
     1033          ! T = Tl +Lv/Cp ql
     1034          zh(ig, ll) = pt(ig, ll) + rlvcp * zl(ig, ll)
     1035          zo(ig, ll) = po(ig, ll) - zl(ig, ll)
     1036        END IF
     1037        ! on ecrit zqsat
     1038        zqsat(ig, ll) = qsatbef(ig)
     1039      END DO
     1040    END DO
     1041    ! AM fin
     1042
     1043    ! -----------------------------------------------------------------------
     1044    ! incrementation eventuelle de tendances precedentes:
     1045    ! ---------------------------------------------------
     1046
     1047    ! PRINT*,'0 OK convect8'
     1048
     1049    DO l = 1, nlay
     1050      DO ig = 1, ngrid
     1051        zpspsk(ig, l) = (pplay(ig, l) / 100000.)**rkappa
     1052        ! zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
     1053        ! zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
     1054        zu(ig, l) = pu(ig, l)
     1055        zv(ig, l) = pv(ig, l)
     1056        ! zo(ig,l)=po(ig,l)
     1057        ! ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
     1058        ! AM attention zh est maintenant le profil de T et plus le profil de
     1059        ! theta !
     1060
     1061        ! T-> Theta
     1062        ztv(ig, l) = zh(ig, l) / zpspsk(ig, l)
     1063        ! AM Theta_v
     1064        ztv(ig, l) = ztv(ig, l) * (1. + retv * (zo(ig, l)) - zl(ig, l))
     1065        ! AM Thetal
     1066        zthl(ig, l) = pt(ig, l) / zpspsk(ig, l)
     1067
     1068      END DO
     1069    END DO
     1070
     1071    ! PRINT*,'1 OK convect8'
     1072    ! --------------------
     1073
     1074
     1075    ! + + + + + + + + + + +
     1076
     1077
     1078    ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
     1079    ! wh,wt,wo ...
     1080
     1081    ! + + + + + + + + + + +  zh,zu,zv,zo,rho
     1082
     1083
     1084    ! --------------------   zlev(1)
     1085    ! \\\\\\\\\\\\\\\\\\\\
     1086
     1087
     1088
     1089    ! -----------------------------------------------------------------------
     1090    ! Calcul des altitudes des couches
     1091    ! -----------------------------------------------------------------------
     1092
     1093    DO l = 2, nlay
     1094      DO ig = 1, ngrid
     1095        zlev(ig, l) = 0.5 * (pphi(ig, l) + pphi(ig, l - 1)) / rg
     1096      END DO
     1097    END DO
     1098    DO ig = 1, ngrid
     1099      zlev(ig, 1) = 0.
     1100      zlev(ig, nlay + 1) = (2. * pphi(ig, klev) - pphi(ig, klev - 1)) / rg
     1101    END DO
     1102    DO l = 1, nlay
     1103      DO ig = 1, ngrid
     1104        zlay(ig, l) = pphi(ig, l) / rg
     1105      END DO
     1106    END DO
     1107    ! calcul de deltaz
     1108    DO l = 1, nlay
     1109      DO ig = 1, ngrid
     1110        deltaz(ig, l) = zlev(ig, l + 1) - zlev(ig, l)
     1111      END DO
     1112    END DO
     1113
     1114    ! PRINT*,'2 OK convect8'
     1115    ! -----------------------------------------------------------------------
     1116    ! Calcul des densites
     1117    ! -----------------------------------------------------------------------
     1118
     1119    DO l = 1, nlay
     1120      DO ig = 1, ngrid
     1121        ! rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
     1122        rho(ig, l) = pplay(ig, l) / (zpspsk(ig, l) * rd * ztv(ig, l))
     1123      END DO
     1124    END DO
     1125
     1126    DO l = 2, nlay
     1127      DO ig = 1, ngrid
     1128        rhobarz(ig, l) = 0.5 * (rho(ig, l) + rho(ig, l - 1))
     1129      END DO
     1130    END DO
     1131
     1132    DO k = 1, nlay
     1133      DO l = 1, nlay + 1
     1134        DO ig = 1, ngrid
     1135          wa(ig, k, l) = 0.
     1136        END DO
     1137      END DO
     1138    END DO
     1139    ! Cr:ajout:calcul de la masse
     1140    DO l = 1, nlay
     1141      DO ig = 1, ngrid
     1142        ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
     1143        masse(ig, l) = (pplev(ig, l) - pplev(ig, l + 1)) / rg
     1144      END DO
     1145    END DO
     1146    ! PRINT*,'3 OK convect8'
     1147    ! ------------------------------------------------------------------
     1148    ! Calcul de w2, quarre de w a partir de la cape
     1149    ! a partir de w2, on calcule wa, vitesse de l'ascendance
     1150
     1151    ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
     1152    ! w2 est stoke dans wa
     1153
     1154    ! ATTENTION: dans convect8, on n'utilise le calcule des wa
     1155    ! independants par couches que pour calculer l'entrainement
     1156    ! a la base et la hauteur max de l'ascendance.
     1157
     1158    ! Indicages:
     1159    ! l'ascendance provenant du niveau k traverse l'interface l avec
     1160    ! une vitesse wa(k,l).
     1161
     1162    ! --------------------
     1163
     1164    ! + + + + + + + + + +
     1165
     1166    ! wa(k,l)   ----       --------------------    l
     1167    ! /\
     1168    ! /||\       + + + + + + + + + +
     1169    ! ||
     1170    ! ||        --------------------
     1171    ! ||
     1172    ! ||        + + + + + + + + + +
     1173    ! ||
     1174    ! ||        --------------------
     1175    ! ||__
     1176    ! |___      + + + + + + + + + +     k
     1177
     1178    ! --------------------
     1179
     1180
     1181
     1182    ! ------------------------------------------------------------------
     1183
     1184    ! CR: ponderation entrainement des couches instables
     1185    ! def des alim_star tels que alim=f*alim_star
     1186    DO l = 1, klev
     1187      DO ig = 1, ngrid
     1188        alim_star(ig, l) = 0.
     1189        alim(ig, l) = 0.
     1190      END DO
     1191    END DO
     1192    ! determination de la longueur de la couche d entrainement
     1193    DO ig = 1, ngrid
     1194      lentr(ig) = 1
     1195    END DO
     1196
     1197    ! on ne considere que les premieres couches instables
     1198    therm = .FALSE.
     1199    DO k = nlay - 2, 1, -1
     1200      DO ig = 1, ngrid
     1201        IF (ztv(ig, k)>ztv(ig, k + 1) .AND. ztv(ig, k + 1)<=ztv(ig, k + 2)) THEN
     1202          lentr(ig) = k + 1
     1203          therm = .TRUE.
     1204        END IF
     1205      END DO
     1206    END DO
     1207
     1208    ! determination du lmin: couche d ou provient le thermique
     1209    DO ig = 1, ngrid
     1210      lmin(ig) = 1
     1211    END DO
     1212    DO ig = 1, ngrid
     1213      DO l = nlay, 2, -1
     1214        IF (ztv(ig, l - 1)>ztv(ig, l)) THEN
     1215          lmin(ig) = l - 1
     1216        END IF
     1217      END DO
     1218    END DO
     1219
     1220    ! definition de l'entrainement des couches
     1221    DO l = 1, klev - 1
     1222      DO ig = 1, ngrid
     1223        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. l>=lmin(ig) .AND. l<lentr(ig)) THEN
     1224          ! def possibles pour alim_star: zdthetadz, dthetadz, zdtheta
     1225          alim_star(ig, l) = max((ztv(ig, l) - ztv(ig, l + 1)), 0.) & ! s
     1226                  ! *(zlev(ig,l+1)-zlev(ig,l))
     1227                  * sqrt(zlev(ig, l + 1))
     1228          ! alim_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
     1229          ! s                         /zlev(ig,lentr(ig)+2)))**(3./2.)
     1230        END IF
     1231      END DO
     1232    END DO
     1233
     1234    ! pas de thermique si couche 1 stable
     1235    DO ig = 1, ngrid
     1236      ! if (lmin(ig).gt.1) THEN
     1237      ! CRnouveau test
     1238      IF (alim_star(ig, 1)<1.E-10) THEN
     1239        DO l = 1, klev
     1240          alim_star(ig, l) = 0.
     1241        END DO
     1242      END IF
     1243    END DO
     1244    ! calcul de l entrainement total
     1245    DO ig = 1, ngrid
     1246      alim_star_tot(ig) = 0.
     1247      entr_star_tot(ig) = 0.
     1248      detr_star_tot(ig) = 0.
     1249    END DO
     1250    DO ig = 1, ngrid
     1251      DO k = 1, klev
     1252        alim_star_tot(ig) = alim_star_tot(ig) + alim_star(ig, k)
     1253      END DO
     1254    END DO
     1255
     1256    ! Calcul entrainement normalise
     1257    DO ig = 1, ngrid
     1258      IF (alim_star_tot(ig)>1.E-10) THEN
     1259        ! do l=1,lentr(ig)
     1260        DO l = 1, klev
     1261          ! def possibles pour entr_star: zdthetadz, dthetadz, zdtheta
     1262          alim_star(ig, l) = alim_star(ig, l) / alim_star_tot(ig)
     1263        END DO
     1264      END IF
     1265    END DO
     1266
     1267    ! PRINT*,'fin calcul alim_star'
     1268
     1269    ! AM:initialisations
     1270    DO k = 1, nlay
     1271      DO ig = 1, ngrid
     1272        ztva(ig, k) = ztv(ig, k)
     1273        ztla(ig, k) = zthl(ig, k)
     1274        zqla(ig, k) = 0.
     1275        zqta(ig, k) = po(ig, k)
     1276        zsat(ig) = .FALSE.
     1277      END DO
     1278    END DO
     1279    DO k = 1, klev
     1280      DO ig = 1, ngrid
     1281        detr_star(ig, k) = 0.
     1282        entr_star(ig, k) = 0.
     1283        detr(ig, k) = 0.
     1284        entr(ig, k) = 0.
     1285      END DO
     1286    END DO
     1287    ! PRINT*,'7 OK convect8'
     1288    DO k = 1, klev + 1
     1289      DO ig = 1, ngrid
     1290        zw2(ig, k) = 0.
     1291        fmc(ig, k) = 0.
     1292        ! CR
     1293        f_star(ig, k) = 0.
     1294        ! RC
     1295        larg_cons(ig, k) = 0.
     1296        larg_detr(ig, k) = 0.
     1297        wa_moy(ig, k) = 0.
     1298      END DO
     1299    END DO
     1300
     1301    ! n     PRINT*,'8 OK convect8'
     1302    DO ig = 1, ngrid
     1303      linter(ig) = 1.
     1304      lmaxa(ig) = 1
     1305      lmix(ig) = 1
     1306      wmaxa(ig) = 0.
     1307    END DO
     1308
     1309    nu_min = l_mix
     1310    nu_max = 1000.
     1311    ! do ig=1,ngrid
     1312    ! nu_max=wmax_sec(ig)
     1313    ! enddo
     1314    DO ig = 1, ngrid
     1315      DO k = 1, klev
     1316        nu(ig, k) = 0.
     1317        nu_e(ig, k) = 0.
     1318      END DO
     1319    END DO
     1320    ! Calcul de l'excès de température du à la diffusion turbulente
     1321    DO ig = 1, ngrid
     1322      DO l = 1, klev
     1323        dtheta(ig, l) = 0.
     1324      END DO
     1325    END DO
     1326    DO ig = 1, ngrid
     1327      DO l = 1, lentr(ig) - 1
     1328        dtheta(ig, l) = sqrt(10. * 0.4 * zlev(ig, l + 1)**2 * 1. * ((ztv(ig, l + 1) - &
     1329                ztv(ig, l)) / (zlev(ig, l + 1) - zlev(ig, l)))**2)
     1330      END DO
     1331    END DO
     1332    ! do l=1,nlay-2
     1333    DO l = 1, klev - 1
     1334      DO ig = 1, ngrid
     1335        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. alim_star(ig, l)>1.E-10 .AND. &
     1336                zw2(ig, l)<1E-10) THEN
     1337          ! AM
     1338          ! test:on rajoute un excès de T dans couche alim
     1339          ! ztla(ig,l)=zthl(ig,l)+dtheta(ig,l)
     1340          ztla(ig, l) = zthl(ig, l)
     1341          ! test: on rajoute un excès de q dans la couche alim
     1342          ! zqta(ig,l)=po(ig,l)+0.001
     1343          zqta(ig, l) = po(ig, l)
     1344          zqla(ig, l) = zl(ig, l)
     1345          ! AM
     1346          f_star(ig, l + 1) = alim_star(ig, l)
     1347          ! test:calcul de dteta
     1348          zw2(ig, l + 1) = 2. * rg * (ztv(ig, l) - ztv(ig, l + 1)) / ztv(ig, l + 1) * &
     1349                  (zlev(ig, l + 1) - zlev(ig, l)) * 0.4 * pphi(ig, l) / (pphi(ig, l + 1) - pphi(ig, l))
     1350          w_est(ig, l + 1) = zw2(ig, l + 1)
     1351          larg_detr(ig, l) = 0.
     1352          ! PRINT*,'coucou boucle 1'
     1353        ELSE IF ((zw2(ig, l)>=1E-10) .AND. (f_star(ig, l) + alim_star(ig, &
     1354                l))>1.E-10) THEN
     1355          ! PRINT*,'coucou boucle 2'
     1356          ! estimation du detrainement a partir de la geometrie du pas
     1357          ! precedent
     1358          IF ((test(ig)==1) .OR. ((.NOT. debut) .AND. (f0(ig)<1.E-10))) THEN
     1359            detr_star(ig, l) = 0.
     1360            entr_star(ig, l) = 0.
     1361            ! PRINT*,'coucou test(ig)',test(ig),f0(ig),zmax0(ig)
     1362          ELSE
     1363            ! PRINT*,'coucou debut detr'
     1364            ! tests sur la definition du detr
     1365            IF (zqla(ig, l - 1)>1.E-10) THEN
     1366              nuage = .TRUE.
     1367            END IF
     1368
     1369            w_est(ig, l + 1) = zw2(ig, l) * ((f_star(ig, l))**2) / (f_star(ig, l) + &
     1370                    alim_star(ig, l))**2 + 2. * rg * (ztva(ig, l - 1) - ztv(ig, l)) / ztv(ig, l) * (&
     1371                    zlev(ig, l + 1) - zlev(ig, l))
     1372            IF (w_est(ig, l + 1)<0.) THEN
     1373              w_est(ig, l + 1) = zw2(ig, l)
     1374            END IF
     1375            IF (l>2) THEN
     1376              IF ((w_est(ig, l + 1)>w_est(ig, l)) .AND. (zlev(ig, &
     1377                      l + 1)<zmax_sec(ig)) .AND. (zqla(ig, l - 1)<1.E-10)) THEN
     1378                detr_star(ig, l) = max(0., (rhobarz(ig, &
     1379                        l + 1) * sqrt(w_est(ig, l + 1)) * sqrt(nu(ig, l) * &
     1380                        zlev(ig, l + 1)) - rhobarz(ig, l) * sqrt(w_est(ig, l)) * sqrt(nu(ig, l) * &
     1381                        zlev(ig, l))) / (r_aspect * zmax_sec(ig)))
     1382              ELSE IF ((zlev(ig, l + 1)<zmax_sec(ig)) .AND. (zqla(ig, &
     1383                      l - 1)<1.E-10)) THEN
     1384                detr_star(ig, l) = -f0(ig) * f_star(ig, lmix(ig)) / (rhobarz(ig, &
     1385                        lmix(ig)) * wmaxa(ig)) * (rhobarz(ig, l + 1) * sqrt(w_est(ig, &
     1386                        l + 1)) * ((zmax_sec(ig) - zlev(ig, l + 1)) / ((zmax_sec(ig) - zlev(ig, &
     1387                        lmix(ig)))))**2. - rhobarz(ig, l) * sqrt(w_est(ig, &
     1388                        l)) * ((zmax_sec(ig) - zlev(ig, l)) / ((zmax_sec(ig) - zlev(ig, lmix(ig &
     1389                        )))))**2.)
     1390              ELSE
     1391                detr_star(ig, l) = 0.002 * f0(ig) * f_star(ig, l) * &
     1392                        (zlev(ig, l + 1) - zlev(ig, l))
     1393
     1394              END IF
     1395            ELSE
     1396              detr_star(ig, l) = 0.
     1397            END IF
     1398
     1399            detr_star(ig, l) = detr_star(ig, l) / f0(ig)
     1400            IF (nuage) THEN
     1401              entr_star(ig, l) = 0.4 * detr_star(ig, l)
     1402            ELSE
     1403              entr_star(ig, l) = 0.4 * detr_star(ig, l)
     1404            END IF
     1405
     1406            IF ((detr_star(ig, l))>f_star(ig, l)) THEN
     1407              detr_star(ig, l) = f_star(ig, l)
     1408              ! entr_star(ig,l)=0.
     1409            END IF
     1410
     1411            IF ((l<lentr(ig))) THEN
     1412              entr_star(ig, l) = 0.
     1413              ! detr_star(ig,l)=0.
     1414            END IF
     1415
     1416            ! PRINT*,'ok detr_star'
     1417          END IF
     1418          ! prise en compte du detrainement dans le calcul du flux
     1419          f_star(ig, l + 1) = f_star(ig, l) + alim_star(ig, l) + &
     1420                  entr_star(ig, l) - detr_star(ig, l)
     1421          ! test
     1422          ! if (f_star(ig,l+1).lt.0.) THEN
     1423          ! f_star(ig,l+1)=0.
     1424          ! entr_star(ig,l)=0.
     1425          ! detr_star(ig,l)=f_star(ig,l)+alim_star(ig,l)
     1426          ! END IF
     1427          ! test sur le signe de f_star
     1428          IF (f_star(ig, l + 1)>1.E-10) THEN
     1429            ! THEN
     1430            ! test
     1431            ! if (((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10)) THEN
     1432            ! AM on melange Tl et qt du thermique
     1433            ! on rajoute un excès de T dans la couche alim
     1434            ! if (l.lt.lentr(ig)) THEN
     1435            ! ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+
     1436            ! s
     1437            ! (alim_star(ig,l)+entr_star(ig,l))*(zthl(ig,l)+dtheta(ig,l)))
     1438            ! s     /(f_star(ig,l+1)+detr_star(ig,l))
     1439            ! else
     1440            ztla(ig, l) = (f_star(ig, l) * ztla(ig, l - 1) + (alim_star(ig, &
     1441                    l) + entr_star(ig, l)) * zthl(ig, l)) / (f_star(ig, l + 1) + detr_star(ig, l))
     1442            ! s                    /(f_star(ig,l+1))
     1443            ! END IF
     1444            ! on rajoute un excès de q dans la couche alim
     1445            ! if (l.lt.lentr(ig)) THEN
     1446            ! zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+
     1447            ! s           (alim_star(ig,l)+entr_star(ig,l))*(po(ig,l)+0.001))
     1448            ! s                 /(f_star(ig,l+1)+detr_star(ig,l))
     1449            ! else
     1450            zqta(ig, l) = (f_star(ig, l) * zqta(ig, l - 1) + (alim_star(ig, &
     1451                    l) + entr_star(ig, l)) * po(ig, l)) / (f_star(ig, l + 1) + detr_star(ig, l))
     1452            ! s                   /(f_star(ig,l+1))
     1453            ! END IF
     1454            ! AM on en deduit thetav et ql du thermique
     1455            ! CR test
     1456            ! Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
     1457            tbef(ig) = ztla(ig, l) * zpspsk(ig, l)
     1458            zdelta = max(0., sign(1., rtt - tbef(ig)))
     1459            qsatbef(ig) = r2es * foeew(tbef(ig), zdelta) / pplev(ig, l)
     1460            qsatbef(ig) = min(0.5, qsatbef(ig))
     1461            zcor = 1. / (1. - retv * qsatbef(ig))
     1462            qsatbef(ig) = qsatbef(ig) * zcor
     1463            zsat(ig) = (max(0., zqta(ig, l) - qsatbef(ig))>1.E-10)
     1464
     1465            IF (zsat(ig) .AND. (1==1)) THEN
     1466              qlbef = max(0., zqta(ig, l) - qsatbef(ig))
     1467              dt = 0.5 * rlvcp * qlbef
     1468              ! WRITE(17,*)'DT0=',DT
     1469              DO WHILE (abs(dt)>ddt0)
     1470                ! PRINT*,'aie'
     1471                tbef(ig) = tbef(ig) + dt
     1472                zdelta = max(0., sign(1., rtt - tbef(ig)))
     1473                qsatbef(ig) = r2es * foeew(tbef(ig), zdelta) / pplev(ig, l)
     1474                qsatbef(ig) = min(0.5, qsatbef(ig))
     1475                zcor = 1. / (1. - retv * qsatbef(ig))
     1476                qsatbef(ig) = qsatbef(ig) * zcor
     1477                qlbef = zqta(ig, l) - qsatbef(ig)
     1478
     1479                zdelta = max(0., sign(1., rtt - tbef(ig)))
     1480                zcvm5 = r5les * (1. - zdelta) + r5ies * zdelta
     1481                zcor = 1. / (1. - retv * qsatbef(ig))
     1482                dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor)
     1483                num = -tbef(ig) + ztla(ig, l) * zpspsk(ig, l) + rlvcp * qlbef
     1484                denom = 1. + rlvcp * dqsat_dt
     1485                IF (denom<1.E-10) THEN
     1486                  PRINT *, 'pb denom'
     1487                END IF
     1488                dt = num / denom
     1489                ! WRITE(17,*)'DT=',DT
     1490              END DO
     1491              zqla(ig, l) = max(0., zqta(ig, l) - qsatbef(ig))
     1492              zqla(ig, l) = max(0., qlbef)
     1493              ! zqla(ig,l)=0.
     1494            END IF
     1495            ! zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
     1496
     1497            ! on ecrit de maniere conservative (sat ou non)
     1498            ! T = Tl +Lv/Cp ql
     1499            ! CR rq utilisation de humidite specifique ou rapport de melange?
     1500            ztva(ig, l) = ztla(ig, l) * zpspsk(ig, l) + rlvcp * zqla(ig, l)
     1501            ztva(ig, l) = ztva(ig, l) / zpspsk(ig, l)
     1502            ! on rajoute le calcul de zha pour diagnostiques (temp potentielle)
     1503            zha(ig, l) = ztva(ig, l)
     1504            ! if (l.lt.lentr(ig)) THEN
     1505            ! ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
     1506            ! s              -zqla(ig,l))-zqla(ig,l)) + 0.1
     1507            ! else
     1508            ztva(ig, l) = ztva(ig, l) * (1. + retv * (zqta(ig, l) - zqla(ig, &
     1509                    l)) - zqla(ig, l))
     1510            ! END IF
     1511            ! ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
     1512            ! s                 /(1.-retv*zqla(ig,l))
     1513            ! ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
     1514            ! ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
     1515            ! s                 /(1.-retv*zqta(ig,l))
     1516            ! s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
     1517            ! s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
     1518            ! WRITE(13,*)zqla(ig,l),zqla(ig,l)/(1.-retv*zqla(ig,l))
     1519            ! on ecrit zqsat
     1520            zqsatth(ig, l) = qsatbef(ig)
     1521            ! enddo
     1522            ! DO ig=1,ngrid
     1523            ! if (zw2(ig,l).ge.1.e-10.AND.
     1524            ! s               f_star(ig,l)+entr_star(ig,l).gt.1.e-10) THEN
     1525            ! mise a jour de la vitesse ascendante (l'air entraine de la couche
     1526            ! consideree commence avec une vitesse nulle).
     1527
     1528            ! if (f_star(ig,l+1).gt.1.e-10) THEN
     1529            zw2(ig, l + 1) = zw2(ig, l) * & ! s
     1530                    ! ((f_star(ig,l)-detr_star(ig,l))**2)
     1531                    ! s                  /f_star(ig,l+1)**2+
     1532                    ((f_star(ig, l))**2) / (f_star(ig, l + 1) + detr_star(ig, l))**2 + & ! s
     1533                    ! /(f_star(ig,l+1))**2+
     1534                    2. * rg * (ztva(ig, l) - ztv(ig, l)) / ztv(ig, l) * (zlev(ig, l + 1) - zlev(ig, l))
     1535            ! s                   *(f_star(ig,l)/f_star(ig,l+1))**2
     1536
     1537          END IF
     1538        END IF
     1539
     1540        IF (zw2(ig, l + 1)<0.) THEN
     1541          linter(ig) = (l * (zw2(ig, l + 1) - zw2(ig, l)) - zw2(ig, l)) / (zw2(ig, l + 1) - zw2(&
     1542                  ig, l))
     1543          zw2(ig, l + 1) = 0.
     1544          ! PRINT*,'linter=',linter(ig)
     1545          ! ELSE IF ((zw2(ig,l+1).lt.1.e-10).AND.(zw2(ig,l+1).ge.0.)) THEN
     1546          ! linter(ig)=l+1
     1547          ! PRINT*,'linter=l',zw2(ig,l),zw2(ig,l+1)
     1548        ELSE
     1549          wa_moy(ig, l + 1) = sqrt(zw2(ig, l + 1))
     1550          ! wa_moy(ig,l+1)=zw2(ig,l+1)
     1551        END IF
     1552        IF (wa_moy(ig, l + 1)>wmaxa(ig)) THEN
     1553          ! lmix est le niveau de la couche ou w (wa_moy) est maximum
     1554          lmix(ig) = l + 1
     1555          wmaxa(ig) = wa_moy(ig, l + 1)
     1556        END IF
     1557      END DO
     1558    END DO
     1559    PRINT *, 'fin calcul zw2'
     1560
     1561    ! Calcul de la couche correspondant a la hauteur du thermique
     1562    DO ig = 1, ngrid
     1563      lmax(ig) = lentr(ig)
     1564    END DO
     1565    DO ig = 1, ngrid
     1566      DO l = nlay, lentr(ig) + 1, -1
     1567        IF (zw2(ig, l)<=1.E-10) THEN
     1568          lmax(ig) = l - 1
     1569        END IF
     1570      END DO
     1571    END DO
     1572    ! pas de thermique si couche 1 stable
     1573    DO ig = 1, ngrid
     1574      IF (lmin(ig)>1) THEN
     1575        lmax(ig) = 1
     1576        lmin(ig) = 1
     1577        lentr(ig) = 1
     1578      END IF
     1579    END DO
     1580
     1581    ! Determination de zw2 max
     1582    DO ig = 1, ngrid
     1583      wmax(ig) = 0.
     1584    END DO
     1585
     1586    DO l = 1, nlay
     1587      DO ig = 1, ngrid
     1588        IF (l<=lmax(ig)) THEN
     1589          IF (zw2(ig, l)<0.) THEN
     1590            PRINT *, 'pb2 zw2<0'
     1591          END IF
     1592          zw2(ig, l) = sqrt(zw2(ig, l))
     1593          wmax(ig) = max(wmax(ig), zw2(ig, l))
     1594        ELSE
     1595          zw2(ig, l) = 0.
     1596        END IF
     1597      END DO
     1598    END DO
     1599
     1600    ! Longueur caracteristique correspondant a la hauteur des thermiques.
     1601    DO ig = 1, ngrid
     1602      zmax(ig) = 0.
     1603      zlevinter(ig) = zlev(ig, 1)
     1604    END DO
     1605    DO ig = 1, ngrid
     1606      ! calcul de zlevinter
     1607      zlevinter(ig) = (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig))) * linter(ig) + &
     1608              zlev(ig, lmax(ig)) - lmax(ig) * (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig)))
     1609      ! pour le cas ou on prend tjs lmin=1
     1610      ! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
     1611      zmax(ig) = max(zmax(ig), zlevinter(ig) - zlev(ig, 1))
     1612      zmax0(ig) = zmax(ig)
     1613      WRITE (11, *) 'ig,lmax,linter', ig, lmax(ig), linter(ig)
     1614      WRITE (12, *) 'ig,zlevinter,zmax', ig, zmax(ig), zlevinter(ig)
     1615    END DO
     1616
     1617    ! Calcul de zmax_sec et wmax_sec
     1618    CALL fermeture_seche(ngrid, nlay, pplay, pplev, pphi, zlev, rhobarz, f0, &
     1619            zpspsk, alim, zh, zo, lentr, lmin, nu_min, nu_max, r_aspect, zmax_sec2, &
     1620            wmax_sec2)
     1621
     1622    PRINT *, 'avant fermeture'
     1623    ! Fermeture,determination de f
     1624    ! en lmax f=d-e
     1625    DO ig = 1, ngrid
     1626      ! entr_star(ig,lmax(ig))=0.
     1627      ! f_star(ig,lmax(ig)+1)=0.
     1628      ! detr_star(ig,lmax(ig))=f_star(ig,lmax(ig))+entr_star(ig,lmax(ig))
     1629      ! s                       +alim_star(ig,lmax(ig))
     1630    END DO
     1631
     1632    DO ig = 1, ngrid
     1633      alim_star2(ig) = 0.
     1634    END DO
     1635    ! calcul de entr_star_tot
     1636    DO ig = 1, ngrid
     1637      DO k = 1, lmix(ig)
     1638        entr_star_tot(ig) = entr_star_tot(ig) & ! s
     1639                ! +entr_star(ig,k)
     1640                + alim_star(ig, k)
     1641        ! s                        -detr_star(ig,k)
     1642        detr_star_tot(ig) = detr_star_tot(ig) & ! s
     1643                ! +alim_star(ig,k)
     1644                - detr_star(ig, k) + entr_star(ig, k)
     1645      END DO
     1646    END DO
     1647
     1648    DO ig = 1, ngrid
     1649      IF (alim_star_tot(ig)<1.E-10) THEN
     1650        f(ig) = 0.
     1651      ELSE
     1652        ! do k=lmin(ig),lentr(ig)
     1653        DO k = 1, lentr(ig)
     1654          alim_star2(ig) = alim_star2(ig) + alim_star(ig, k)**2 / (rho(ig, k) * (&
     1655                  zlev(ig, k + 1) - zlev(ig, k)))
     1656        END DO
     1657        IF ((zmax_sec(ig)>1.E-10) .AND. (1==1)) THEN
     1658          f(ig) = wmax_sec(ig) / (max(500., zmax_sec(ig)) * r_aspect * alim_star2(ig))
     1659          f(ig) = f(ig) + (f0(ig) - f(ig)) * exp((-ptimestep / zmax_sec(ig)) * wmax_sec &
     1660                  (ig))
     1661        ELSE
     1662          f(ig) = wmax(ig) / (max(500., zmax(ig)) * r_aspect * alim_star2(ig))
     1663          f(ig) = f(ig) + (f0(ig) - f(ig)) * exp((-ptimestep / zmax(ig)) * wmax(ig))
     1664        END IF
     1665      END IF
     1666      f0(ig) = f(ig)
     1667    END DO
     1668    PRINT *, 'apres fermeture'
     1669    ! Calcul de l'entrainement
     1670    DO ig = 1, ngrid
     1671      DO k = 1, klev
     1672        alim(ig, k) = f(ig) * alim_star(ig, k)
     1673      END DO
     1674    END DO
     1675    ! CR:test pour entrainer moins que la masse
     1676    ! do ig=1,ngrid
     1677    ! do l=1,lentr(ig)
     1678    ! if ((alim(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) THEN
     1679    ! alim(ig,l+1)=alim(ig,l+1)+alim(ig,l)
     1680    ! s                       -0.9*masse(ig,l)/ptimestep
     1681    ! alim(ig,l)=0.9*masse(ig,l)/ptimestep
     1682    ! END IF
     1683    ! enddo
     1684    ! enddo
     1685    ! calcul du détrainement
     1686    DO ig = 1, klon
     1687      DO k = 1, klev
     1688        detr(ig, k) = f(ig) * detr_star(ig, k)
     1689        IF (detr(ig, k)<0.) THEN
     1690          ! PRINT*,'detr1<0!!!'
     1691        END IF
     1692      END DO
     1693      DO k = 1, klev
     1694        entr(ig, k) = f(ig) * entr_star(ig, k)
     1695        IF (entr(ig, k)<0.) THEN
     1696          ! PRINT*,'entr1<0!!!'
     1697        END IF
     1698      END DO
     1699    END DO
     1700
     1701    ! do ig=1,ngrid
     1702    ! do l=1,klev
     1703    ! if (((detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep).gt.
     1704    ! s          (masse(ig,l))) THEN
     1705    ! PRINT*,'d2+e2+a2>m2','ig=',ig,'l=',l,'lmax(ig)=',lmax(ig),'d+e+a='
     1706    ! s,(detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep,'m=',masse(ig,l)
     1707    ! END IF
     1708    ! enddo
     1709    ! enddo
     1710    ! Calcul des flux
     1711
     1712    DO ig = 1, ngrid
     1713      DO l = 1, lmax(ig)
     1714        ! do l=1,klev
     1715        ! fmc(ig,l+1)=f(ig)*f_star(ig,l+1)
     1716        fmc(ig, l + 1) = fmc(ig, l) + alim(ig, l) + entr(ig, l) - detr(ig, l)
     1717        ! PRINT*,'??!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
     1718        ! s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
     1719        ! s  'f+1=',fmc(ig,l+1)
     1720        IF (fmc(ig, l + 1)<0.) THEN
     1721          PRINT *, 'fmc1<0', l + 1, lmax(ig), fmc(ig, l + 1)
     1722          fmc(ig, l + 1) = fmc(ig, l)
     1723          detr(ig, l) = alim(ig, l) + entr(ig, l)
     1724          ! fmc(ig,l+1)=0.
     1725          ! PRINT*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1)
     1726        END IF
     1727        ! if ((fmc(ig,l+1).gt.fmc(ig,l)).AND.(l.gt.lentr(ig))) THEN
     1728        ! f_old=fmc(ig,l+1)
     1729        ! fmc(ig,l+1)=fmc(ig,l)
     1730        ! detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
     1731        ! END IF
     1732
     1733        ! if ((fmc(ig,l+1).gt.fmc(ig,l)).AND.(l.gt.lentr(ig))) THEN
     1734        ! f_old=fmc(ig,l+1)
     1735        ! fmc(ig,l+1)=fmc(ig,l)
     1736        ! detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l)
     1737        ! END IF
     1738        ! rajout du test sur alpha croissant
     1739        ! if test
     1740        ! if (1.EQ.0) THEN
     1741        IF (l==klev) THEN
     1742          PRINT *, 'THERMCELL PB ig=', ig, '   l=', l
     1743          abort_message = 'THERMCELL PB'
     1744          CALL abort_physic(modname, abort_message, 1)
     1745        END IF
     1746        ! if ((zw2(ig,l+1).gt.1.e-10).AND.(zw2(ig,l).gt.1.e-10).AND.
     1747        ! s     (l.ge.lentr(ig)).AND.
     1748        IF ((zw2(ig, l + 1)>1.E-10) .AND. (zw2(ig, l)>1.E-10) .AND. (l>=lentr(ig))) &
     1749                THEN
     1750          IF (((fmc(ig, l + 1) / (rhobarz(ig, l + 1) * zw2(ig, l + 1)))>(fmc(ig, l) / &
     1751                  (rhobarz(ig, l) * zw2(ig, l))))) THEN
     1752            f_old = fmc(ig, l + 1)
     1753            fmc(ig, l + 1) = fmc(ig, l) * rhobarz(ig, l + 1) * zw2(ig, l + 1) / &
     1754                    (rhobarz(ig, l) * zw2(ig, l))
     1755            detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l + 1)
     1756            ! detr(ig,l)=(fmc(ig,l+1)-fmc(ig,l))/(0.4-1.)
     1757            ! entr(ig,l)=0.4*detr(ig,l)
     1758            ! entr(ig,l)=fmc(ig,l+1)-fmc(ig,l)+detr(ig,l)
     1759          END IF
     1760        END IF
     1761        IF ((fmc(ig, l + 1)>fmc(ig, l)) .AND. (l>lentr(ig))) THEN
     1762          f_old = fmc(ig, l + 1)
     1763          fmc(ig, l + 1) = fmc(ig, l)
     1764          detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l + 1)
     1765        END IF
     1766        IF (detr(ig, l)>fmc(ig, l)) THEN
     1767          detr(ig, l) = fmc(ig, l)
     1768          entr(ig, l) = fmc(ig, l + 1) - alim(ig, l)
     1769        END IF
     1770        IF (fmc(ig, l + 1)<0.) THEN
     1771          detr(ig, l) = detr(ig, l) + fmc(ig, l + 1)
     1772          fmc(ig, l + 1) = 0.
     1773          PRINT *, 'fmc2<0', l + 1, lmax(ig)
     1774        END IF
     1775
     1776        ! test pour ne pas avoir f=0 et d=e/=0
     1777        ! if (fmc(ig,l+1).lt.1.e-10) THEN
     1778        ! detr(ig,l+1)=0.
     1779        ! entr(ig,l+1)=0.
     1780        ! zqla(ig,l+1)=0.
     1781        ! zw2(ig,l+1)=0.
     1782        ! lmax(ig)=l+1
     1783        ! zmax(ig)=zlev(ig,lmax(ig))
     1784        ! END IF
     1785        IF (zw2(ig, l + 1)>1.E-10) THEN
     1786          IF ((((fmc(ig, l + 1)) / (rhobarz(ig, l + 1) * zw2(ig, l + 1)))>1.)) THEN
     1787            f_old = fmc(ig, l + 1)
     1788            fmc(ig, l + 1) = rhobarz(ig, l + 1) * zw2(ig, l + 1)
     1789            zw2(ig, l + 1) = 0.
     1790            zqla(ig, l + 1) = 0.
     1791            detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l + 1)
     1792            lmax(ig) = l + 1
     1793            zmax(ig) = zlev(ig, lmax(ig))
     1794            PRINT *, 'alpha>1', l + 1, lmax(ig)
     1795          END IF
     1796        END IF
     1797        ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
     1798        ! END IF test
     1799        ! END IF
     1800      END DO
     1801    END DO
     1802    DO ig = 1, ngrid
     1803      ! if (fmc(ig,lmax(ig)+1).NE.0.) THEN
     1804      fmc(ig, lmax(ig) + 1) = 0.
     1805      entr(ig, lmax(ig)) = 0.
     1806      detr(ig, lmax(ig)) = fmc(ig, lmax(ig)) + entr(ig, lmax(ig)) + &
     1807              alim(ig, lmax(ig))
     1808      ! END IF
     1809    END DO
     1810    ! test sur le signe de fmc
     1811    DO ig = 1, ngrid
     1812      DO l = 1, klev + 1
     1813        IF (fmc(ig, l)<0.) THEN
     1814          PRINT *, 'fm1<0!!!', 'ig=', ig, 'l=', l, 'a=', alim(ig, l - 1), 'e=', &
     1815                  entr(ig, l - 1), 'f=', fmc(ig, l - 1), 'd=', detr(ig, l - 1), 'f+1=', &
     1816                  fmc(ig, l)
     1817        END IF
     1818      END DO
     1819    END DO
     1820    ! test de verification
     1821    DO ig = 1, ngrid
     1822      DO l = 1, lmax(ig)
     1823        IF ((abs(fmc(ig, l + 1) - fmc(ig, l) - alim(ig, l) - entr(ig, l) + &
     1824                detr(ig, l)))>1.E-4) THEN
     1825          ! PRINT*,'pbcm!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
     1826          ! s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
     1827          ! s  'f+1=',fmc(ig,l+1)
     1828        END IF
     1829        IF (detr(ig, l)<0.) THEN
     1830          PRINT *, 'detrdemi<0!!!'
     1831        END IF
     1832      END DO
     1833    END DO
     1834
     1835    ! RC
     1836    ! CR def de  zmix continu (profil parabolique des vitesses)
     1837    DO ig = 1, ngrid
     1838      IF (lmix(ig)>1.) THEN
     1839        ! test
     1840        IF (((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig))) - &
     1841                (zlev(ig, lmix(ig) + 1))) - (zw2(ig, lmix(ig)) - &
     1842                zw2(ig, lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1)) - &
     1843                (zlev(ig, lmix(ig)))))>1E-10) THEN
     1844
     1845          zmix(ig) = ((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig)) &
     1846                  )**2 - (zlev(ig, lmix(ig) + 1))**2) - (zw2(ig, lmix(ig)) - zw2(ig, &
     1847                  lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1))**2 - (zlev(ig, lmix(ig)))**2)) / &
     1848                  (2. * ((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig))) - &
     1849                          (zlev(ig, lmix(ig) + 1))) - (zw2(ig, lmix(ig)) - &
     1850                          zw2(ig, lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1)) - (zlev(ig, lmix(ig))))))
     1851        ELSE
     1852          zmix(ig) = zlev(ig, lmix(ig))
     1853          PRINT *, 'pb zmix'
     1854        END IF
     1855      ELSE
     1856        zmix(ig) = 0.
     1857      END IF
     1858      ! test
     1859      IF ((zmax(ig) - zmix(ig))<=0.) THEN
     1860        zmix(ig) = 0.9 * zmax(ig)
     1861        ! PRINT*,'pb zmix>zmax'
     1862      END IF
     1863    END DO
     1864    DO ig = 1, klon
     1865      zmix0(ig) = zmix(ig)
     1866    END DO
     1867
     1868    ! calcul du nouveau lmix correspondant
     1869    DO ig = 1, ngrid
     1870      DO l = 1, klev
     1871        IF (zmix(ig)>=zlev(ig, l) .AND. zmix(ig)<zlev(ig, l + 1)) THEN
     1872          lmix(ig) = l
     1873        END IF
     1874      END DO
     1875    END DO
     1876
     1877    ! ne devrait pas arriver!!!!!
     1878    DO ig = 1, ngrid
     1879      DO l = 1, klev
     1880        IF (detr(ig, l)>(fmc(ig, l) + alim(ig, l)) + entr(ig, l)) THEN
     1881          PRINT *, 'detr2>fmc2!!!', 'ig=', ig, 'l=', l, 'd=', detr(ig, l), &
     1882                  'f=', fmc(ig, l), 'lmax=', lmax(ig)
     1883          ! detr(ig,l)=fmc(ig,l)+alim(ig,l)+entr(ig,l)
     1884          ! entr(ig,l)=0.
     1885          ! fmc(ig,l+1)=0.
     1886          ! zw2(ig,l+1)=0.
     1887          ! zqla(ig,l+1)=0.
     1888          PRINT *, 'pb!fm=0 et f_star>0', l, lmax(ig)
     1889          ! lmax(ig)=l
     1890        END IF
     1891      END DO
     1892    END DO
     1893    DO ig = 1, ngrid
     1894      DO l = lmax(ig) + 1, klev + 1
     1895        ! fmc(ig,l)=0.
     1896        ! detr(ig,l)=0.
     1897        ! entr(ig,l)=0.
     1898        ! zw2(ig,l)=0.
     1899        ! zqla(ig,l)=0.
     1900      END DO
     1901    END DO
     1902
     1903    ! Calcul du detrainement lors du premier passage
     1904    ! PRINT*,'9 OK convect8'
     1905    ! PRINT*,'WA1 ',wa_moy
     1906
     1907    ! determination de l'indice du debut de la mixed layer ou w decroit
     1908
     1909    ! calcul de la largeur de chaque ascendance dans le cas conservatif.
     1910    ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
     1911    ! d'une couche est égale à la hauteur de la couche alimentante.
     1912    ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
     1913    ! de la vitesse d'entrainement horizontal dans la couche alimentante.
     1914
     1915    DO l = 2, nlay
     1916      DO ig = 1, ngrid
     1917        IF (l<=lmax(ig) .AND. (test(ig)==1)) THEN
     1918          zw = max(wa_moy(ig, l), 1.E-10)
     1919          larg_cons(ig, l) = zmax(ig) * r_aspect * fmc(ig, l) / (rhobarz(ig, l) * zw)
     1920        END IF
     1921      END DO
     1922    END DO
     1923
     1924    DO l = 2, nlay
     1925      DO ig = 1, ngrid
     1926        IF (l<=lmax(ig) .AND. (test(ig)==1)) THEN
     1927          ! if (idetr.EQ.0) THEN
     1928          ! cette option est finalement en dur.
     1929          IF ((l_mix * zlev(ig, l))<0.) THEN
     1930            PRINT *, 'pb l_mix*zlev<0'
     1931          END IF
     1932          ! CR: test: nouvelle def de lambda
     1933          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     1934          IF (zw2(ig, l)>1.E-10) THEN
     1935            larg_detr(ig, l) = sqrt((l_mix / zw2(ig, l)) * zlev(ig, l))
     1936          ELSE
     1937            larg_detr(ig, l) = sqrt(l_mix * zlev(ig, l))
     1938          END IF
     1939          ! ELSE IF (idetr.EQ.1) THEN
     1940          ! larg_detr(ig,l)=larg_cons(ig,l)
     1941          ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
     1942          ! ELSE IF (idetr.EQ.2) THEN
     1943          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     1944          ! s            *sqrt(wa_moy(ig,l))
     1945          ! ELSE IF (idetr.EQ.4) THEN
     1946          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     1947          ! s            *wa_moy(ig,l)
     1948          ! END IF
     1949        END IF
     1950      END DO
     1951    END DO
     1952
     1953    ! PRINT*,'10 OK convect8'
     1954    ! PRINT*,'WA2 ',wa_moy
     1955    ! cal1cul de la fraction de la maille concernée par l'ascendance en tenant
     1956    ! compte de l'epluchage du thermique.
     1957
     1958    DO l = 2, nlay
     1959      DO ig = 1, ngrid
     1960        IF (larg_cons(ig, l)>1. .AND. (test(ig)==1)) THEN
     1961          ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
     1962          fraca(ig, l) = (larg_cons(ig, l) - larg_detr(ig, l)) / (r_aspect * zmax(ig))
     1963          ! test
     1964          fraca(ig, l) = max(fraca(ig, l), 0.)
     1965          fraca(ig, l) = min(fraca(ig, l), 0.5)
     1966          fracd(ig, l) = 1. - fraca(ig, l)
     1967          fracc(ig, l) = larg_cons(ig, l) / (r_aspect * zmax(ig))
     1968        ELSE
     1969          ! wa_moy(ig,l)=0.
     1970          fraca(ig, l) = 0.
     1971          fracc(ig, l) = 0.
     1972          fracd(ig, l) = 1.
     1973        END IF
     1974      END DO
     1975    END DO
     1976    ! CR: calcul de fracazmix
     1977    DO ig = 1, ngrid
     1978      IF (test(ig)==1) THEN
     1979        fracazmix(ig) = (fraca(ig, lmix(ig) + 1) - fraca(ig, lmix(ig))) / &
     1980                (zlev(ig, lmix(ig) + 1) - zlev(ig, lmix(ig))) * zmix(ig) + &
     1981                fraca(ig, lmix(ig)) - zlev(ig, lmix(ig)) * (fraca(ig, lmix(ig) + 1) - fraca(&
     1982                ig, lmix(ig))) / (zlev(ig, lmix(ig) + 1) - zlev(ig, lmix(ig)))
     1983      END IF
     1984    END DO
     1985
     1986    DO l = 2, nlay
     1987      DO ig = 1, ngrid
     1988        IF (larg_cons(ig, l)>1. .AND. (test(ig)==1)) THEN
     1989          IF (l>lmix(ig)) THEN
     1990            ! test
     1991            IF (zmax(ig) - zmix(ig)<1.E-10) THEN
     1992              ! PRINT*,'pb xxx'
     1993              xxx(ig, l) = (lmax(ig) + 1. - l) / (lmax(ig) + 1. - lmix(ig))
     1994            ELSE
     1995              xxx(ig, l) = (zmax(ig) - zlev(ig, l)) / (zmax(ig) - zmix(ig))
     1996            END IF
     1997            IF (idetr==0) THEN
     1998              fraca(ig, l) = fracazmix(ig)
     1999            ELSE IF (idetr==1) THEN
     2000              fraca(ig, l) = fracazmix(ig) * xxx(ig, l)
     2001            ELSE IF (idetr==2) THEN
     2002              fraca(ig, l) = fracazmix(ig) * (1. - (1. - xxx(ig, l))**2)
     2003            ELSE
     2004              fraca(ig, l) = fracazmix(ig) * xxx(ig, l)**2
     2005            END IF
     2006            ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
     2007            fraca(ig, l) = max(fraca(ig, l), 0.)
     2008            fraca(ig, l) = min(fraca(ig, l), 0.5)
     2009            fracd(ig, l) = 1. - fraca(ig, l)
     2010            fracc(ig, l) = larg_cons(ig, l) / (r_aspect * zmax(ig))
     2011          END IF
     2012        END IF
     2013      END DO
     2014    END DO
     2015
     2016    PRINT *, 'fin calcul fraca'
     2017    ! PRINT*,'11 OK convect8'
     2018    ! PRINT*,'Ea3 ',wa_moy
     2019    ! ------------------------------------------------------------------
     2020    ! Calcul de fracd, wd
     2021    ! somme wa - wd = 0
     2022    ! ------------------------------------------------------------------
     2023
     2024    DO ig = 1, ngrid
     2025      fm(ig, 1) = 0.
     2026      fm(ig, nlay + 1) = 0.
     2027    END DO
     2028
     2029    DO l = 2, nlay
     2030      DO ig = 1, ngrid
     2031        IF (test(ig)==1) THEN
     2032          fm(ig, l) = fraca(ig, l) * wa_moy(ig, l) * rhobarz(ig, l)
     2033          ! CR:test
     2034          IF (alim(ig, l - 1)<1E-10 .AND. fm(ig, l)>fm(ig, l - 1) .AND. l>lmix(ig)) &
     2035                  THEN
     2036            fm(ig, l) = fm(ig, l - 1)
     2037            ! WRITE(1,*)'ajustement fm, l',l
     2038          END IF
     2039          ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
     2040          ! RC
     2041        END IF
     2042      END DO
     2043      DO ig = 1, ngrid
     2044        IF (fracd(ig, l)<0.1 .AND. (test(ig)==1)) THEN
     2045          abort_message = 'fracd trop petit'
     2046          CALL abort_physic(modname, abort_message, 1)
     2047        ELSE
     2048          ! vitesse descendante "diagnostique"
     2049          wd(ig, l) = fm(ig, l) / (fracd(ig, l) * rhobarz(ig, l))
     2050        END IF
     2051      END DO
     2052    END DO
     2053
    2192054    DO l = 1, nlay + 1
    2202055      DO ig = 1, ngrid
    221         wa(ig, k, l) = 0.
    222       END DO
    223     END DO
    224   END DO
    225 
    226   ! PRINT*,'3 OK convect8'
    227   ! ------------------------------------------------------------------
    228   ! Calcul de w2, quarre de w a partir de la cape
    229   ! a partir de w2, on calcule wa, vitesse de l'ascendance
    230 
    231   ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
    232   ! w2 est stoke dans wa
    233 
    234   ! ATTENTION: dans convect8, on n'utilise le calcule des wa
    235   ! independants par couches que pour calculer l'entrainement
    236   ! a la base et la hauteur max de l'ascendance.
    237 
    238   ! Indicages:
    239   ! l'ascendance provenant du niveau k traverse l'interface l avec
    240   ! une vitesse wa(k,l).
    241 
    242   ! --------------------
    243 
    244   ! + + + + + + + + + +
    245 
    246   ! wa(k,l)   ----       --------------------    l
    247   ! /\
    248   ! /||\       + + + + + + + + + +
    249   ! ||
    250   ! ||        --------------------
    251   ! ||
    252   ! ||        + + + + + + + + + +
    253   ! ||
    254   ! ||        --------------------
    255   ! ||__
    256   ! |___      + + + + + + + + + +     k
    257 
    258   ! --------------------
    259 
    260 
    261 
    262   ! ------------------------------------------------------------------
    263 
    264 
    265   DO k = 1, nlay - 1
    266     DO ig = 1, ngrid
    267       wa(ig, k, k) = 0.
    268       wa(ig, k, k+1) = 2.*rg*(ztv(ig,k)-ztv(ig,k+1))/ztv(ig, k+1)* &
    269         (zlev(ig,k+1)-zlev(ig,k))
    270     END DO
    271     DO l = k + 1, nlay - 1
    272       DO ig = 1, ngrid
    273         wa(ig, k, l+1) = wa(ig, k, l) + 2.*rg*(ztv(ig,k)-ztv(ig,l))/ztv(ig, l &
    274           )*(zlev(ig,l+1)-zlev(ig,l))
    275       END DO
    276     END DO
    277     DO ig = 1, ngrid
    278       wa(ig, k, nlay+1) = 0.
    279     END DO
    280   END DO
    281 
    282   ! PRINT*,'4 OK convect8'
    283   ! Calcul de la couche correspondant a la hauteur du thermique
    284   DO k = 1, nlay - 1
    285     DO ig = 1, ngrid
    286       lmax(ig, k) = k
    287     END DO
    288     DO l = nlay, k + 1, -1
    289       DO ig = 1, ngrid
    290         IF (wa(ig,k,l)<=1.E-10) lmax(ig, k) = l - 1
    291       END DO
    292     END DO
    293   END DO
    294 
    295   ! PRINT*,'5 OK convect8'
    296   ! Calcule du w max du thermique
    297   DO k = 1, nlay
    298     DO ig = 1, ngrid
    299       wmax(ig, k) = 0.
    300     END DO
    301   END DO
    302 
    303   DO k = 1, nlay - 1
    304     DO l = k, nlay
    305       DO ig = 1, ngrid
    306         IF (l<=lmax(ig,k)) THEN
    307           wa(ig, k, l) = sqrt(wa(ig,k,l))
    308           wmax(ig, k) = max(wmax(ig,k), wa(ig,k,l))
     2056        IF (test(ig)==0) THEN
     2057          fm(ig, l) = fmc(ig, l)
     2058        END IF
     2059      END DO
     2060    END DO
     2061
     2062    ! fin du first
     2063    DO l = 1, nlay
     2064      DO ig = 1, ngrid
     2065        ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
     2066        masse(ig, l) = (pplev(ig, l) - pplev(ig, l + 1)) / rg
     2067      END DO
     2068    END DO
     2069
     2070    ! PRINT*,'12 OK convect8'
     2071    ! PRINT*,'WA4 ',wa_moy
     2072    ! c------------------------------------------------------------------
     2073    ! calcul du transport vertical
     2074    ! ------------------------------------------------------------------
     2075
     2076    GO TO 4444
     2077    ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
     2078    DO l = 2, nlay - 1
     2079      DO ig = 1, ngrid
     2080        IF (fm(ig, l + 1) * ptimestep>masse(ig, l) .AND. fm(ig, l + 1) * ptimestep>masse(&
     2081                ig, l + 1)) THEN
     2082          PRINT *, 'WARN!!! FM>M ig=', ig, ' l=', l, '  FM=', &
     2083                  fm(ig, l + 1) * ptimestep, '   M=', masse(ig, l), masse(ig, l + 1)
     2084        END IF
     2085      END DO
     2086    END DO
     2087
     2088    DO l = 1, nlay
     2089      DO ig = 1, ngrid
     2090        IF ((alim(ig, l) + entr(ig, l)) * ptimestep>masse(ig, l)) THEN
     2091          PRINT *, 'WARN!!! E>M ig=', ig, ' l=', l, '  E==', &
     2092                  (entr(ig, l) + alim(ig, l)) * ptimestep, '   M=', masse(ig, l)
     2093        END IF
     2094      END DO
     2095    END DO
     2096
     2097    DO l = 1, nlay
     2098      DO ig = 1, ngrid
     2099        IF (.NOT. fm(ig, l)>=0. .OR. .NOT. fm(ig, l)<=10.) THEN
     2100          ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
     2101          ! s         ,'   FM=',fm(ig,l)
     2102        END IF
     2103        IF (.NOT. masse(ig, l)>=1.E-10 .OR. .NOT. masse(ig, l)<=1.E4) THEN
     2104          ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
     2105          ! s         ,'   M=',masse(ig,l)
     2106          ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
     2107          ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
     2108          ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
     2109          ! s                ,zlev(ig,l+1),zlev(ig,l)
     2110          ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
     2111          ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
     2112        END IF
     2113        IF (.NOT. alim(ig, l)>=0. .OR. .NOT. alim(ig, l)<=10.) THEN
     2114          ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
     2115          ! s         ,'   E=',entr(ig,l)
     2116        END IF
     2117      END DO
     2118    END DO
     2119
     2120    4444 CONTINUE
     2121
     2122    ! CR:redefinition du entr
     2123    ! CR:test:on ne change pas la def du entr mais la def du fm
     2124    DO l = 1, nlay
     2125      DO ig = 1, ngrid
     2126        IF (test(ig)==1) THEN
     2127          detr(ig, l) = fm(ig, l) + alim(ig, l) - fm(ig, l + 1)
     2128          IF (detr(ig, l)<0.) THEN
     2129            ! entr(ig,l)=entr(ig,l)-detr(ig,l)
     2130            fm(ig, l + 1) = fm(ig, l) + alim(ig, l)
     2131            detr(ig, l) = 0.
     2132            ! WRITE(11,*)'l,ig,entr',l,ig,entr(ig,l)
     2133            ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
     2134          END IF
     2135        END IF
     2136      END DO
     2137    END DO
     2138    ! RC
     2139
     2140    IF (w2di==1) THEN
     2141      fm0 = fm0 + ptimestep * (fm - fm0) / tho
     2142      entr0 = entr0 + ptimestep * (alim + entr - entr0) / tho
     2143    ELSE
     2144      fm0 = fm
     2145      entr0 = alim + entr
     2146      detr0 = detr
     2147      alim0 = alim
     2148      ! zoa=zqta
     2149      ! entr0=alim
     2150    END IF
     2151
     2152    IF (1==1) THEN
     2153      ! CALL dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
     2154      ! .    ,zh,zdhadj,zha)
     2155      ! CALL dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
     2156      ! .    ,zo,pdoadj,zoa)
     2157      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zthl, &
     2158              zdthladj, zta)
     2159      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, po, pdoadj, &
     2160              zoa)
     2161    ELSE
     2162      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
     2163              zdhadj, zha)
     2164      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
     2165              pdoadj, zoa)
     2166    END IF
     2167
     2168    IF (1==0) THEN
     2169      CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
     2170              zu, zv, pduadj, pdvadj, zua, zva)
     2171    ELSE
     2172      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
     2173              zua)
     2174      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
     2175              zva)
     2176    END IF
     2177
     2178    ! Calcul des moments
     2179    ! do l=1,nlay
     2180    ! do ig=1,ngrid
     2181    ! zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
     2182    ! zf2=zf/(1.-zf)
     2183    ! thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
     2184    ! wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
     2185    ! enddo
     2186    ! enddo
     2187
     2188
     2189
     2190
     2191
     2192
     2193    ! PRINT*,'13 OK convect8'
     2194    ! PRINT*,'WA5 ',wa_moy
     2195    DO l = 1, nlay
     2196      DO ig = 1, ngrid
     2197        ! pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
     2198        pdtadj(ig, l) = zdthladj(ig, l) * zpspsk(ig, l)
     2199      END DO
     2200    END DO
     2201
     2202
     2203    ! do l=1,nlay
     2204    ! do ig=1,ngrid
     2205    ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
     2206    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     2207    ! s         ,'   pdtadj=',pdtadj(ig,l)
     2208    ! END IF
     2209    ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
     2210    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     2211    ! s         ,'   pdoadj=',pdoadj(ig,l)
     2212    ! END IF
     2213    ! enddo
     2214    ! enddo
     2215
     2216    ! PRINT*,'14 OK convect8'
     2217    ! ------------------------------------------------------------------
     2218    ! Calculs pour les sorties
     2219    ! ------------------------------------------------------------------
     2220    ! calcul de fraca pour les sorties
     2221    DO l = 2, klev
     2222      DO ig = 1, klon
     2223        IF (zw2(ig, l)>1.E-10) THEN
     2224          fraca(ig, l) = fm(ig, l) / (rhobarz(ig, l) * zw2(ig, l))
    3092225        ELSE
     2226          fraca(ig, l) = 0.
     2227        END IF
     2228      END DO
     2229    END DO
     2230    IF (sorties) THEN
     2231      DO l = 1, nlay
     2232        DO ig = 1, ngrid
     2233          zla(ig, l) = (1. - fracd(ig, l)) * zmax(ig)
     2234          zld(ig, l) = fracd(ig, l) * zmax(ig)
     2235          IF (1. - fracd(ig, l)>1.E-10) zwa(ig, l) = wd(ig, l) * fracd(ig, l) / &
     2236                  (1. - fracd(ig, l))
     2237        END DO
     2238      END DO
     2239      ! CR calcul du niveau de condensation
     2240      ! initialisation
     2241      DO ig = 1, ngrid
     2242        nivcon(ig) = 0.
     2243        zcon(ig) = 0.
     2244      END DO
     2245      DO k = nlay, 1, -1
     2246        DO ig = 1, ngrid
     2247          IF (zqla(ig, k)>1E-10) THEN
     2248            nivcon(ig) = k
     2249            zcon(ig) = zlev(ig, k)
     2250          END IF
     2251          ! if (zcon(ig).gt.1.e-10) THEN
     2252          ! nuage=.TRUE.
     2253          ! else
     2254          ! nuage=.FALSE.
     2255          ! END IF
     2256        END DO
     2257      END DO
     2258
     2259      DO l = 1, nlay
     2260        DO ig = 1, ngrid
     2261          zf = fraca(ig, l)
     2262          zf2 = zf / (1. - zf)
     2263          thetath2(ig, l) = zf2 * (zha(ig, l) - zh(ig, l) / zpspsk(ig, l))**2
     2264          wth2(ig, l) = zf2 * (zw2(ig, l))**2
     2265          ! PRINT*,'wth2=',wth2(ig,l)
     2266          wth3(ig, l) = zf2 * (1 - 2. * fraca(ig, l)) / (1 - fraca(ig, l)) * zw2(ig, l) * &
     2267                  zw2(ig, l) * zw2(ig, l)
     2268          q2(ig, l) = zf2 * (zqta(ig, l) * 1000. - po(ig, l) * 1000.)**2
     2269          ! test: on calcul q2/po=ratqsc
     2270          ! if (nuage) THEN
     2271          ratqscth(ig, l) = sqrt(q2(ig, l)) / (po(ig, l) * 1000.)
     2272          ! else
     2273          ! ratqscth(ig,l)=0.
     2274          ! END IF
     2275        END DO
     2276      END DO
     2277      ! calcul du ratqscdiff
     2278      sum = 0.
     2279      sumdiff = 0.
     2280      ratqsdiff(:, :) = 0.
     2281      DO ig = 1, ngrid
     2282        DO l = 1, lentr(ig)
     2283          sum = sum + alim_star(ig, l) * zqta(ig, l) * 1000.
     2284        END DO
     2285      END DO
     2286      DO ig = 1, ngrid
     2287        DO l = 1, lentr(ig)
     2288          zf = fraca(ig, l)
     2289          zf2 = zf / (1. - zf)
     2290          sumdiff = sumdiff + alim_star(ig, l) * (zqta(ig, l) * 1000. - sum)**2
     2291          ! ratqsdiff=ratqsdiff+alim_star(ig,l)*
     2292          ! s          (zqta(ig,l)*1000.-po(ig,l)*1000.)**2
     2293        END DO
     2294      END DO
     2295      DO l = 1, klev
     2296        DO ig = 1, ngrid
     2297          ratqsdiff(ig, l) = sqrt(sumdiff) / (po(ig, l) * 1000.)
     2298          ! WRITE(11,*)'ratqsdiff=',ratqsdiff(ig,l)
     2299        END DO
     2300      END DO
     2301
     2302    END IF
     2303
     2304    ! PRINT*,'19 OK convect8'
     2305
     2306  END SUBROUTINE thermcell_cld
     2307
     2308  SUBROUTINE thermcell_eau(ngrid, nlay, ptimestep, pplay, pplev, pphi, pu, pv, &
     2309          pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s
     2310          ! ,pu_therm,pv_therm
     2311          , r_aspect, l_mix, w2di, tho)
     2312
     2313    USE dimphy
     2314    IMPLICIT NONE
     2315
     2316    ! =======================================================================
     2317
     2318    ! Calcul du transport verticale dans la couche limite en presence
     2319    ! de "thermiques" explicitement representes
     2320
     2321    ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
     2322
     2323    ! le thermique est supposé homogène et dissipé par mélange avec
     2324    ! son environnement. la longueur l_mix contrôle l'efficacité du
     2325    ! mélange
     2326
     2327    ! Le calcul du transport des différentes espèces se fait en prenant
     2328    ! en compte:
     2329    ! 1. un flux de masse montant
     2330    ! 2. un flux de masse descendant
     2331    ! 3. un entrainement
     2332    ! 4. un detrainement
     2333
     2334    ! =======================================================================
     2335
     2336    ! -----------------------------------------------------------------------
     2337    ! declarations:
     2338    ! -------------
     2339
     2340    include "YOMCST.h"
     2341    include "YOETHF.h"
     2342    include "FCTTRE.h"
     2343
     2344    ! arguments:
     2345    ! ----------
     2346
     2347    INTEGER ngrid, nlay, w2di
     2348    REAL tho
     2349    REAL ptimestep, l_mix, r_aspect
     2350    REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
     2351    REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
     2352    REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
     2353    REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
     2354    REAL pplay(ngrid, nlay), pplev(ngrid, nlay + 1)
     2355    REAL pphi(ngrid, nlay)
     2356
     2357    INTEGER idetr
     2358    SAVE idetr
     2359    DATA idetr/3/
     2360    !$OMP THREADPRIVATE(idetr)
     2361
     2362    ! local:
     2363    ! ------
     2364
     2365    INTEGER ig, k, l, lmaxa(klon), lmix(klon)
     2366    REAL zsortie1d(klon)
     2367    ! CR: on remplace lmax(klon,klev+1)
     2368    INTEGER lmax(klon), lmin(klon), lentr(klon)
     2369    REAL linter(klon)
     2370    REAL zmix(klon), fracazmix(klon)
     2371    ! RC
     2372    REAL zmax(klon), zw, zz, zw2(klon, klev + 1), ztva(klon, klev), zzz
     2373
     2374    REAL zlev(klon, klev + 1), zlay(klon, klev)
     2375    REAL zh(klon, klev), zdhadj(klon, klev)
     2376    REAL zthl(klon, klev), zdthladj(klon, klev)
     2377    REAL ztv(klon, klev)
     2378    REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
     2379    REAL zl(klon, klev)
     2380    REAL wh(klon, klev + 1)
     2381    REAL wu(klon, klev + 1), wv(klon, klev + 1), wo(klon, klev + 1)
     2382    REAL zla(klon, klev + 1)
     2383    REAL zwa(klon, klev + 1)
     2384    REAL zld(klon, klev + 1)
     2385    REAL zwd(klon, klev + 1)
     2386    REAL zsortie(klon, klev)
     2387    REAL zva(klon, klev)
     2388    REAL zua(klon, klev)
     2389    REAL zoa(klon, klev)
     2390
     2391    REAL zta(klon, klev)
     2392    REAL zha(klon, klev)
     2393    REAL wa_moy(klon, klev + 1)
     2394    REAL fraca(klon, klev + 1)
     2395    REAL fracc(klon, klev + 1)
     2396    REAL zf, zf2
     2397    REAL thetath2(klon, klev), wth2(klon, klev)
     2398    ! common/comtherm/thetath2,wth2
     2399
     2400    REAL count_time
     2401    INTEGER ialt
     2402
     2403    LOGICAL sorties
     2404    REAL rho(klon, klev), rhobarz(klon, klev + 1), masse(klon, klev)
     2405    REAL zpspsk(klon, klev)
     2406
     2407    ! real wmax(klon,klev),wmaxa(klon)
     2408    REAL wmax(klon), wmaxa(klon)
     2409    REAL wa(klon, klev, klev + 1)
     2410    REAL wd(klon, klev + 1)
     2411    REAL larg_part(klon, klev, klev + 1)
     2412    REAL fracd(klon, klev + 1)
     2413    REAL xxx(klon, klev + 1)
     2414    REAL larg_cons(klon, klev + 1)
     2415    REAL larg_detr(klon, klev + 1)
     2416    REAL fm0(klon, klev + 1), entr0(klon, klev), detr(klon, klev)
     2417    REAL pu_therm(klon, klev), pv_therm(klon, klev)
     2418    REAL fm(klon, klev + 1), entr(klon, klev)
     2419    REAL fmc(klon, klev + 1)
     2420
     2421    REAL zcor, zdelta, zcvm5, qlbef
     2422    REAL tbef(klon), qsatbef(klon)
     2423    REAL dqsat_dt, dt, num, denom
     2424    REAL reps, rlvcp, ddt0
     2425    REAL ztla(klon, klev), zqla(klon, klev), zqta(klon, klev)
     2426
     2427    PARAMETER (ddt0 = .01)
     2428
     2429    ! CR:nouvelles variables
     2430    REAL f_star(klon, klev + 1), entr_star(klon, klev)
     2431    REAL entr_star_tot(klon), entr_star2(klon)
     2432    REAL f(klon), f0(klon)
     2433    REAL zlevinter(klon)
     2434    LOGICAL first
     2435    DATA first/.FALSE./
     2436    SAVE first
     2437    !$OMP THREADPRIVATE(first)
     2438
     2439    ! RC
     2440
     2441    CHARACTER *2 str2
     2442    CHARACTER *10 str10
     2443
     2444    CHARACTER (LEN = 20) :: modname = 'thermcell_eau'
     2445    CHARACTER (LEN = 80) :: abort_message
     2446
     2447    LOGICAL vtest(klon), down
     2448    LOGICAL zsat(klon)
     2449
     2450    INTEGER ncorrec, ll
     2451    SAVE ncorrec
     2452    DATA ncorrec/0/
     2453    !$OMP THREADPRIVATE(ncorrec)
     2454
     2455
     2456
     2457    ! -----------------------------------------------------------------------
     2458    ! initialisation:
     2459    ! ---------------
     2460
     2461    sorties = .TRUE.
     2462    IF (ngrid/=klon) THEN
     2463      PRINT *
     2464      PRINT *, 'STOP dans convadj'
     2465      PRINT *, 'ngrid    =', ngrid
     2466      PRINT *, 'klon  =', klon
     2467    END IF
     2468
     2469    ! Initialisation
     2470    rlvcp = rlvtt / rcpd
     2471    reps = rd / rv
     2472
     2473    ! -----------------------------------------------------------------------
     2474    ! AM Calcul de T,q,ql a partir de Tl et qT
     2475    ! ---------------------------------------------------
     2476
     2477    ! Pr Tprec=Tl calcul de qsat
     2478    ! Si qsat>qT T=Tl, q=qT
     2479    ! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt)
     2480    ! On cherche DDT < DDT0
     2481
     2482    ! defaut
     2483    DO ll = 1, nlay
     2484      DO ig = 1, ngrid
     2485        zo(ig, ll) = po(ig, ll)
     2486        zl(ig, ll) = 0.
     2487        zh(ig, ll) = pt(ig, ll)
     2488      END DO
     2489    END DO
     2490    DO ig = 1, ngrid
     2491      zsat(ig) = .FALSE.
     2492    END DO
     2493
     2494    DO ll = 1, nlay
     2495      ! les points insatures sont definitifs
     2496      DO ig = 1, ngrid
     2497        tbef(ig) = pt(ig, ll)
     2498        zdelta = max(0., sign(1., rtt - tbef(ig)))
     2499        qsatbef(ig) = r2es * foeew(tbef(ig), zdelta) / pplev(ig, ll)
     2500        qsatbef(ig) = min(0.5, qsatbef(ig))
     2501        zcor = 1. / (1. - retv * qsatbef(ig))
     2502        qsatbef(ig) = qsatbef(ig) * zcor
     2503        zsat(ig) = (max(0., po(ig, ll) - qsatbef(ig))>0.00001)
     2504      END DO
     2505
     2506      DO ig = 1, ngrid
     2507        IF (zsat(ig)) THEN
     2508          qlbef = max(0., po(ig, ll) - qsatbef(ig))
     2509          ! si sature: ql est surestime, d'ou la sous-relax
     2510          dt = 0.5 * rlvcp * qlbef
     2511          ! on pourra enchainer 2 ou 3 calculs sans Do while
     2512          DO WHILE (dt>ddt0)
     2513            ! il faut verifier si c,a conserve quand on repasse en insature ...
     2514            tbef(ig) = tbef(ig) + dt
     2515            zdelta = max(0., sign(1., rtt - tbef(ig)))
     2516            qsatbef(ig) = r2es * foeew(tbef(ig), zdelta) / pplev(ig, ll)
     2517            qsatbef(ig) = min(0.5, qsatbef(ig))
     2518            zcor = 1. / (1. - retv * qsatbef(ig))
     2519            qsatbef(ig) = qsatbef(ig) * zcor
     2520            ! on veut le signe de qlbef
     2521            qlbef = po(ig, ll) - qsatbef(ig)
     2522            ! dqsat_dT
     2523            zdelta = max(0., sign(1., rtt - tbef(ig)))
     2524            zcvm5 = r5les * (1. - zdelta) + r5ies * zdelta
     2525            zcor = 1. / (1. - retv * qsatbef(ig))
     2526            dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor)
     2527            num = -tbef(ig) + pt(ig, ll) + rlvcp * qlbef
     2528            denom = 1. + rlvcp * dqsat_dt
     2529            dt = num / denom
     2530          END DO
     2531          ! on ecrit de maniere conservative (sat ou non)
     2532          zl(ig, ll) = max(0., qlbef)
     2533          ! T = Tl +Lv/Cp ql
     2534          zh(ig, ll) = pt(ig, ll) + rlvcp * zl(ig, ll)
     2535          zo(ig, ll) = po(ig, ll) - zl(ig, ll)
     2536        END IF
     2537      END DO
     2538    END DO
     2539    ! AM fin
     2540
     2541    ! -----------------------------------------------------------------------
     2542    ! incrementation eventuelle de tendances precedentes:
     2543    ! ---------------------------------------------------
     2544
     2545    ! PRINT*,'0 OK convect8'
     2546
     2547    DO l = 1, nlay
     2548      DO ig = 1, ngrid
     2549        zpspsk(ig, l) = (pplay(ig, l) / pplev(ig, 1))**rkappa
     2550        ! zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
     2551        zu(ig, l) = pu(ig, l)
     2552        zv(ig, l) = pv(ig, l)
     2553        ! zo(ig,l)=po(ig,l)
     2554        ! ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
     2555        ! AM attention zh est maintenant le profil de T et plus le profil de
     2556        ! theta !
     2557
     2558        ! T-> Theta
     2559        ztv(ig, l) = zh(ig, l) / zpspsk(ig, l)
     2560        ! AM Theta_v
     2561        ztv(ig, l) = ztv(ig, l) * (1. + retv * (zo(ig, l)) - zl(ig, l))
     2562        ! AM Thetal
     2563        zthl(ig, l) = pt(ig, l) / zpspsk(ig, l)
     2564
     2565      END DO
     2566    END DO
     2567
     2568    ! PRINT*,'1 OK convect8'
     2569    ! --------------------
     2570
     2571
     2572    ! + + + + + + + + + + +
     2573
     2574
     2575    ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
     2576    ! wh,wt,wo ...
     2577
     2578    ! + + + + + + + + + + +  zh,zu,zv,zo,rho
     2579
     2580
     2581    ! --------------------   zlev(1)
     2582    ! \\\\\\\\\\\\\\\\\\\\
     2583
     2584
     2585
     2586    ! -----------------------------------------------------------------------
     2587    ! Calcul des altitudes des couches
     2588    ! -----------------------------------------------------------------------
     2589
     2590    DO l = 2, nlay
     2591      DO ig = 1, ngrid
     2592        zlev(ig, l) = 0.5 * (pphi(ig, l) + pphi(ig, l - 1)) / rg
     2593      END DO
     2594    END DO
     2595    DO ig = 1, ngrid
     2596      zlev(ig, 1) = 0.
     2597      zlev(ig, nlay + 1) = (2. * pphi(ig, klev) - pphi(ig, klev - 1)) / rg
     2598    END DO
     2599    DO l = 1, nlay
     2600      DO ig = 1, ngrid
     2601        zlay(ig, l) = pphi(ig, l) / rg
     2602      END DO
     2603    END DO
     2604
     2605    ! PRINT*,'2 OK convect8'
     2606    ! -----------------------------------------------------------------------
     2607    ! Calcul des densites
     2608    ! -----------------------------------------------------------------------
     2609
     2610    DO l = 1, nlay
     2611      DO ig = 1, ngrid
     2612        ! rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
     2613        rho(ig, l) = pplay(ig, l) / (zpspsk(ig, l) * rd * ztv(ig, l))
     2614      END DO
     2615    END DO
     2616
     2617    DO l = 2, nlay
     2618      DO ig = 1, ngrid
     2619        rhobarz(ig, l) = 0.5 * (rho(ig, l) + rho(ig, l - 1))
     2620      END DO
     2621    END DO
     2622
     2623    DO k = 1, nlay
     2624      DO l = 1, nlay + 1
     2625        DO ig = 1, ngrid
    3102626          wa(ig, k, l) = 0.
    311         END IF
    312       END DO
    313     END DO
    314   END DO
    315 
    316   DO k = 1, nlay - 1
    317     DO ig = 1, ngrid
    318       pu_therm(ig, k) = sqrt(wmax(ig,k))
    319       pv_therm(ig, k) = sqrt(wmax(ig,k))
    320     END DO
    321   END DO
    322 
    323   ! PRINT*,'6 OK convect8'
    324   ! Longueur caracteristique correspondant a la hauteur des thermiques.
    325   DO ig = 1, ngrid
    326     zmax(ig) = 500.
    327   END DO
    328   ! PRINT*,'LMAX LMAX LMAX '
    329   DO k = 1, nlay - 1
    330     DO ig = 1, ngrid
    331       zmax(ig) = max(zmax(ig), zlev(ig,lmax(ig,k))-zlev(ig,k))
    332     END DO
    333     ! PRINT*,k,lmax(1,k)
    334   END DO
    335   ! PRINT*,'ZMAX ZMAX ZMAX ',zmax
    336   ! CALL dump2d(iim,jjm-1,zmax(2:ngrid-1),'ZMAX      ')
    337 
    338   ! PRINT*,'OKl336'
    339   ! Calcul de l'entrainement.
    340   ! Le rapport d'aspect relie la largeur de l'ascendance a l'epaisseur
    341   ! de la couche d'alimentation en partant du principe que la vitesse
    342   ! maximum dans l'ascendance est la vitesse d'entrainement horizontale.
    343   DO k = 1, nlay
    344     DO ig = 1, ngrid
    345       zzz = rho(ig, k)*wmax(ig, k)*(zlev(ig,k+1)-zlev(ig,k))/ &
    346         (zmax(ig)*r_aspect)
    347       IF (w2di==2) THEN
    348         entr(ig, k) = entr(ig, k) + ptimestep*(zzz-entr(ig,k))/tho
     2627        END DO
     2628      END DO
     2629    END DO
     2630
     2631    ! PRINT*,'3 OK convect8'
     2632    ! ------------------------------------------------------------------
     2633    ! Calcul de w2, quarre de w a partir de la cape
     2634    ! a partir de w2, on calcule wa, vitesse de l'ascendance
     2635
     2636    ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
     2637    ! w2 est stoke dans wa
     2638
     2639    ! ATTENTION: dans convect8, on n'utilise le calcule des wa
     2640    ! independants par couches que pour calculer l'entrainement
     2641    ! a la base et la hauteur max de l'ascendance.
     2642
     2643    ! Indicages:
     2644    ! l'ascendance provenant du niveau k traverse l'interface l avec
     2645    ! une vitesse wa(k,l).
     2646
     2647    ! --------------------
     2648
     2649    ! + + + + + + + + + +
     2650
     2651    ! wa(k,l)   ----       --------------------    l
     2652    ! /\
     2653    ! /||\       + + + + + + + + + +
     2654    ! ||
     2655    ! ||        --------------------
     2656    ! ||
     2657    ! ||        + + + + + + + + + +
     2658    ! ||
     2659    ! ||        --------------------
     2660    ! ||__
     2661    ! |___      + + + + + + + + + +     k
     2662
     2663    ! --------------------
     2664
     2665
     2666
     2667    ! ------------------------------------------------------------------
     2668
     2669    ! CR: ponderation entrainement des couches instables
     2670    ! def des entr_star tels que entr=f*entr_star
     2671    DO l = 1, klev
     2672      DO ig = 1, ngrid
     2673        entr_star(ig, l) = 0.
     2674      END DO
     2675    END DO
     2676    ! determination de la longueur de la couche d entrainement
     2677    DO ig = 1, ngrid
     2678      lentr(ig) = 1
     2679    END DO
     2680
     2681    ! on ne considere que les premieres couches instables
     2682    DO k = nlay - 1, 1, -1
     2683      DO ig = 1, ngrid
     2684        IF (ztv(ig, k)>ztv(ig, k + 1) .AND. ztv(ig, k + 1)<ztv(ig, k + 2)) THEN
     2685          lentr(ig) = k
     2686        END IF
     2687      END DO
     2688    END DO
     2689
     2690    ! determination du lmin: couche d ou provient le thermique
     2691    DO ig = 1, ngrid
     2692      lmin(ig) = 1
     2693    END DO
     2694    DO ig = 1, ngrid
     2695      DO l = nlay, 2, -1
     2696        IF (ztv(ig, l - 1)>ztv(ig, l)) THEN
     2697          lmin(ig) = l - 1
     2698        END IF
     2699      END DO
     2700    END DO
     2701
     2702    ! definition de l'entrainement des couches
     2703    DO l = 1, klev - 1
     2704      DO ig = 1, ngrid
     2705        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN
     2706          entr_star(ig, l) = (ztv(ig, l) - ztv(ig, l + 1)) * (zlev(ig, l + 1) - zlev(ig, l))
     2707        END IF
     2708      END DO
     2709    END DO
     2710    ! pas de thermique si couche 1 stable
     2711    DO ig = 1, ngrid
     2712      IF (lmin(ig)>1) THEN
     2713        DO l = 1, klev
     2714          entr_star(ig, l) = 0.
     2715        END DO
     2716      END IF
     2717    END DO
     2718    ! calcul de l entrainement total
     2719    DO ig = 1, ngrid
     2720      entr_star_tot(ig) = 0.
     2721    END DO
     2722    DO ig = 1, ngrid
     2723      DO k = 1, klev
     2724        entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k)
     2725      END DO
     2726    END DO
     2727
     2728    DO k = 1, klev
     2729      DO ig = 1, ngrid
     2730        ztva(ig, k) = ztv(ig, k)
     2731      END DO
     2732    END DO
     2733    ! RC
     2734    ! AM:initialisations
     2735    DO k = 1, nlay
     2736      DO ig = 1, ngrid
     2737        ztva(ig, k) = ztv(ig, k)
     2738        ztla(ig, k) = zthl(ig, k)
     2739        zqla(ig, k) = 0.
     2740        zqta(ig, k) = po(ig, k)
     2741        zsat(ig) = .FALSE.
     2742      END DO
     2743    END DO
     2744
     2745    ! PRINT*,'7 OK convect8'
     2746    DO k = 1, klev + 1
     2747      DO ig = 1, ngrid
     2748        zw2(ig, k) = 0.
     2749        fmc(ig, k) = 0.
     2750        ! CR
     2751        f_star(ig, k) = 0.
     2752        ! RC
     2753        larg_cons(ig, k) = 0.
     2754        larg_detr(ig, k) = 0.
     2755        wa_moy(ig, k) = 0.
     2756      END DO
     2757    END DO
     2758
     2759    ! PRINT*,'8 OK convect8'
     2760    DO ig = 1, ngrid
     2761      linter(ig) = 1.
     2762      lmaxa(ig) = 1
     2763      lmix(ig) = 1
     2764      wmaxa(ig) = 0.
     2765    END DO
     2766
     2767    ! CR:
     2768    DO l = 1, nlay - 2
     2769      DO ig = 1, ngrid
     2770        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. entr_star(ig, l)>1.E-10 .AND. &
     2771                zw2(ig, l)<1E-10) THEN
     2772          ! AM
     2773          ztla(ig, l) = zthl(ig, l)
     2774          zqta(ig, l) = po(ig, l)
     2775          zqla(ig, l) = zl(ig, l)
     2776          ! AM
     2777          f_star(ig, l + 1) = entr_star(ig, l)
     2778          ! test:calcul de dteta
     2779          zw2(ig, l + 1) = 2. * rg * (ztv(ig, l) - ztv(ig, l + 1)) / ztv(ig, l + 1) * &
     2780                  (zlev(ig, l + 1) - zlev(ig, l)) * 0.4 * pphi(ig, l) / (pphi(ig, l + 1) - pphi(ig, l))
     2781          larg_detr(ig, l) = 0.
     2782        ELSE IF ((zw2(ig, l)>=1E-10) .AND. (f_star(ig, l) + entr_star(ig, &
     2783                l)>1.E-10)) THEN
     2784          f_star(ig, l + 1) = f_star(ig, l) + entr_star(ig, l)
     2785
     2786          ! AM on melange Tl et qt du thermique
     2787          ztla(ig, l) = (f_star(ig, l) * ztla(ig, l - 1) + entr_star(ig, l) * zthl(ig, l)) / &
     2788                  f_star(ig, l + 1)
     2789          zqta(ig, l) = (f_star(ig, l) * zqta(ig, l - 1) + entr_star(ig, l) * po(ig, l)) / &
     2790                  f_star(ig, l + 1)
     2791
     2792          ! ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
     2793          ! s                    *ztv(ig,l))/f_star(ig,l+1)
     2794
     2795          ! AM on en deduit thetav et ql du thermique
     2796          tbef(ig) = ztla(ig, l) * zpspsk(ig, l)
     2797          zdelta = max(0., sign(1., rtt - tbef(ig)))
     2798          qsatbef(ig) = r2es * foeew(tbef(ig), zdelta) / pplev(ig, l)
     2799          qsatbef(ig) = min(0.5, qsatbef(ig))
     2800          zcor = 1. / (1. - retv * qsatbef(ig))
     2801          qsatbef(ig) = qsatbef(ig) * zcor
     2802          zsat(ig) = (max(0., zqta(ig, l) - qsatbef(ig))>0.00001)
     2803        END IF
     2804      END DO
     2805      DO ig = 1, ngrid
     2806        IF (zsat(ig)) THEN
     2807          qlbef = max(0., zqta(ig, l) - qsatbef(ig))
     2808          dt = 0.5 * rlvcp * qlbef
     2809          DO WHILE (dt>ddt0)
     2810            tbef(ig) = tbef(ig) + dt
     2811            zdelta = max(0., sign(1., rtt - tbef(ig)))
     2812            qsatbef(ig) = r2es * foeew(tbef(ig), zdelta) / pplev(ig, l)
     2813            qsatbef(ig) = min(0.5, qsatbef(ig))
     2814            zcor = 1. / (1. - retv * qsatbef(ig))
     2815            qsatbef(ig) = qsatbef(ig) * zcor
     2816            qlbef = zqta(ig, l) - qsatbef(ig)
     2817
     2818            zdelta = max(0., sign(1., rtt - tbef(ig)))
     2819            zcvm5 = r5les * (1. - zdelta) + r5ies * zdelta
     2820            zcor = 1. / (1. - retv * qsatbef(ig))
     2821            dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor)
     2822            num = -tbef(ig) + ztla(ig, l) * zpspsk(ig, l) + rlvcp * qlbef
     2823            denom = 1. + rlvcp * dqsat_dt
     2824            dt = num / denom
     2825          END DO
     2826          zqla(ig, l) = max(0., zqta(ig, l) - qsatbef(ig))
     2827        END IF
     2828        ! on ecrit de maniere conservative (sat ou non)
     2829        ! T = Tl +Lv/Cp ql
     2830        ztva(ig, l) = ztla(ig, l) * zpspsk(ig, l) + rlvcp * zqla(ig, l)
     2831        ztva(ig, l) = ztva(ig, l) / zpspsk(ig, l)
     2832        ztva(ig, l) = ztva(ig, l) * (1. + retv * (zqta(ig, l) - zqla(ig, l)) - zqla(ig, l))
     2833
     2834      END DO
     2835      DO ig = 1, ngrid
     2836        IF (zw2(ig, l)>=1.E-10 .AND. f_star(ig, l) + entr_star(ig, l)>1.E-10) THEN
     2837          ! mise a jour de la vitesse ascendante (l'air entraine de la couche
     2838          ! consideree commence avec une vitesse nulle).
     2839
     2840          zw2(ig, l + 1) = zw2(ig, l) * (f_star(ig, l) / f_star(ig, l + 1))**2 + &
     2841                  2. * rg * (ztva(ig, l) - ztv(ig, l)) / ztv(ig, l) * (zlev(ig, l + 1) - zlev(ig, l))
     2842        END IF
     2843        ! determination de zmax continu par interpolation lineaire
     2844        IF (zw2(ig, l + 1)<0.) THEN
     2845          linter(ig) = (l * (zw2(ig, l + 1) - zw2(ig, l)) - zw2(ig, l)) / (zw2(ig, l + 1) - zw2(&
     2846                  ig, l))
     2847          zw2(ig, l + 1) = 0.
     2848          lmaxa(ig) = l
     2849        ELSE
     2850          wa_moy(ig, l + 1) = sqrt(zw2(ig, l + 1))
     2851        END IF
     2852        IF (wa_moy(ig, l + 1)>wmaxa(ig)) THEN
     2853          ! lmix est le niveau de la couche ou w (wa_moy) est maximum
     2854          lmix(ig) = l + 1
     2855          wmaxa(ig) = wa_moy(ig, l + 1)
     2856        END IF
     2857      END DO
     2858    END DO
     2859
     2860    ! Calcul de la couche correspondant a la hauteur du thermique
     2861    DO ig = 1, ngrid
     2862      lmax(ig) = lentr(ig)
     2863    END DO
     2864    DO ig = 1, ngrid
     2865      DO l = nlay, lentr(ig) + 1, -1
     2866        IF (zw2(ig, l)<=1.E-10) THEN
     2867          lmax(ig) = l - 1
     2868        END IF
     2869      END DO
     2870    END DO
     2871    ! pas de thermique si couche 1 stable
     2872    DO ig = 1, ngrid
     2873      IF (lmin(ig)>1) THEN
     2874        lmax(ig) = 1
     2875        lmin(ig) = 1
     2876      END IF
     2877    END DO
     2878
     2879    ! Determination de zw2 max
     2880    DO ig = 1, ngrid
     2881      wmax(ig) = 0.
     2882    END DO
     2883
     2884    DO l = 1, nlay
     2885      DO ig = 1, ngrid
     2886        IF (l<=lmax(ig)) THEN
     2887          zw2(ig, l) = sqrt(zw2(ig, l))
     2888          wmax(ig) = max(wmax(ig), zw2(ig, l))
     2889        ELSE
     2890          zw2(ig, l) = 0.
     2891        END IF
     2892      END DO
     2893    END DO
     2894
     2895    ! Longueur caracteristique correspondant a la hauteur des thermiques.
     2896    DO ig = 1, ngrid
     2897      zmax(ig) = 500.
     2898      zlevinter(ig) = zlev(ig, 1)
     2899    END DO
     2900    DO ig = 1, ngrid
     2901      ! calcul de zlevinter
     2902      zlevinter(ig) = (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig))) * linter(ig) + &
     2903              zlev(ig, lmax(ig)) - lmax(ig) * (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig)))
     2904      zmax(ig) = max(zmax(ig), zlevinter(ig) - zlev(ig, lmin(ig)))
     2905    END DO
     2906
     2907    ! Fermeture,determination de f
     2908    DO ig = 1, ngrid
     2909      entr_star2(ig) = 0.
     2910    END DO
     2911    DO ig = 1, ngrid
     2912      IF (entr_star_tot(ig)<1.E-10) THEN
     2913        f(ig) = 0.
    3492914      ELSE
    350         entr(ig, k) = zzz
     2915        DO k = lmin(ig), lentr(ig)
     2916          entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2 / (rho(ig, k) * (&
     2917                  zlev(ig, k + 1) - zlev(ig, k)))
     2918        END DO
     2919        ! Nouvelle fermeture
     2920        f(ig) = wmax(ig) / (zmax(ig) * r_aspect * entr_star2(ig)) * entr_star_tot(ig)
     2921        ! test
     2922        IF (first) THEN
     2923          f(ig) = f(ig) + (f0(ig) - f(ig)) * exp(-ptimestep / zmax(ig) * wmax(ig))
     2924        END IF
    3512925      END IF
    352       ztva(ig, k) = ztv(ig, k)
    353     END DO
    354   END DO
    355 
    356 
    357   ! PRINT*,'7 OK convect8'
    358   DO k = 1, klev + 1
    359     DO ig = 1, ngrid
    360       zw2(ig, k) = 0.
    361       fmc(ig, k) = 0.
    362       larg_cons(ig, k) = 0.
    363       larg_detr(ig, k) = 0.
    364       wa_moy(ig, k) = 0.
    365     END DO
    366   END DO
    367 
    368   ! PRINT*,'8 OK convect8'
    369   DO ig = 1, ngrid
    370     lmaxa(ig) = 1
    371     lmix(ig) = 1
    372     wmaxa(ig) = 0.
    373   END DO
    374 
    375 
    376   ! PRINT*,'OKl372'
    377   DO l = 1, nlay - 2
    378     DO ig = 1, ngrid
    379       ! if (zw2(ig,l).lt.1.e-10.AND.ztv(ig,l).gt.ztv(ig,l+1)) THEN
    380       ! PRINT*,'COUCOU ',l,zw2(ig,l),ztv(ig,l),ztv(ig,l+1)
    381       IF (zw2(ig,l)<1.E-10 .AND. ztv(ig,l)>ztv(ig,l+1) .AND. &
    382           entr(ig,l)>1.E-10) THEN
    383         ! PRINT*,'COUCOU cas 1'
    384         ! Initialisation de l'ascendance
    385         ! lmix(ig)=1
    386         ztva(ig, l) = ztv(ig, l)
    387         fmc(ig, l) = 0.
    388         fmc(ig, l+1) = entr(ig, l)
    389         zw2(ig, l) = 0.
    390         ! if (.NOT.ztv(ig,l+1).gt.150.) THEN
    391         ! PRINT*,'ig,l+1,ztv(ig,l+1)'
    392         ! PRINT*, ig,l+1,ztv(ig,l+1)
    393         ! END IF
    394         zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* &
    395           (zlev(ig,l+1)-zlev(ig,l))
    396         larg_detr(ig, l) = 0.
    397       ELSE IF (zw2(ig,l)>=1.E-10 .AND. fmc(ig,l)+entr(ig,l)>1.E-10) THEN
    398         ! Incrementation...
    399         fmc(ig, l+1) = fmc(ig, l) + entr(ig, l)
    400         ! if (.NOT.fmc(ig,l+1).gt.1.e-15) THEN
    401         ! PRINT*,'ig,l+1,fmc(ig,l+1)'
    402         ! PRINT*, ig,l+1,fmc(ig,l+1)
    403         ! PRINT*,'Fmc ',(fmc(ig,ll),ll=1,klev+1)
    404         ! PRINT*,'W2 ',(zw2(ig,ll),ll=1,klev+1)
    405         ! PRINT*,'Tv ',(ztv(ig,ll),ll=1,klev)
    406         ! PRINT*,'Entr ',(entr(ig,ll),ll=1,klev)
    407         ! END IF
    408         ztva(ig, l) = (fmc(ig,l)*ztva(ig,l-1)+entr(ig,l)*ztv(ig,l))/ &
    409           fmc(ig, l+1)
    410         ! mise a jour de la vitesse ascendante (l'air entraine de la couche
    411         ! consideree commence avec une vitesse nulle).
    412         zw2(ig, l+1) = zw2(ig, l)*(fmc(ig,l)/fmc(ig,l+1))**2 + &
    413           2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l))
     2926      f0(ig) = f(ig)
     2927      first = .TRUE.
     2928    END DO
     2929
     2930    ! Calcul de l'entrainement
     2931    DO k = 1, klev
     2932      DO ig = 1, ngrid
     2933        entr(ig, k) = f(ig) * entr_star(ig, k)
     2934      END DO
     2935    END DO
     2936    ! Calcul des flux
     2937    DO ig = 1, ngrid
     2938      DO l = 1, lmax(ig) - 1
     2939        fmc(ig, l + 1) = fmc(ig, l) + entr(ig, l)
     2940      END DO
     2941    END DO
     2942
     2943    ! RC
     2944
     2945
     2946    ! PRINT*,'9 OK convect8'
     2947    ! PRINT*,'WA1 ',wa_moy
     2948
     2949    ! determination de l'indice du debut de la mixed layer ou w decroit
     2950
     2951    ! calcul de la largeur de chaque ascendance dans le cas conservatif.
     2952    ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
     2953    ! d'une couche est égale à la hauteur de la couche alimentante.
     2954    ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
     2955    ! de la vitesse d'entrainement horizontal dans la couche alimentante.
     2956
     2957    DO l = 2, nlay
     2958      DO ig = 1, ngrid
     2959        IF (l<=lmaxa(ig)) THEN
     2960          zw = max(wa_moy(ig, l), 1.E-10)
     2961          larg_cons(ig, l) = zmax(ig) * r_aspect * fmc(ig, l) / (rhobarz(ig, l) * zw)
     2962        END IF
     2963      END DO
     2964    END DO
     2965
     2966    DO l = 2, nlay
     2967      DO ig = 1, ngrid
     2968        IF (l<=lmaxa(ig)) THEN
     2969          ! if (idetr.EQ.0) THEN
     2970          ! cette option est finalement en dur.
     2971          larg_detr(ig, l) = sqrt(l_mix * zlev(ig, l))
     2972          ! ELSE IF (idetr.EQ.1) THEN
     2973          ! larg_detr(ig,l)=larg_cons(ig,l)
     2974          ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
     2975          ! ELSE IF (idetr.EQ.2) THEN
     2976          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     2977          ! s            *sqrt(wa_moy(ig,l))
     2978          ! ELSE IF (idetr.EQ.4) THEN
     2979          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     2980          ! s            *wa_moy(ig,l)
     2981          ! END IF
     2982        END IF
     2983      END DO
     2984    END DO
     2985
     2986    ! PRINT*,'10 OK convect8'
     2987    ! PRINT*,'WA2 ',wa_moy
     2988    ! calcul de la fraction de la maille concernée par l'ascendance en tenant
     2989    ! compte de l'epluchage du thermique.
     2990
     2991    ! CR def de  zmix continu (profil parabolique des vitesses)
     2992    DO ig = 1, ngrid
     2993      IF (lmix(ig)>1.) THEN
     2994        zmix(ig) = ((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig))) &
     2995                **2 - (zlev(ig, lmix(ig) + 1))**2) - (zw2(ig, lmix(ig)) - zw2(ig, &
     2996                lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1))**2 - (zlev(ig, lmix(ig)))**2)) / &
     2997                (2. * ((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig))) - &
     2998                        (zlev(ig, lmix(ig) + 1))) - (zw2(ig, lmix(ig)) - zw2(ig, lmix(ig) + 1)) * ((zlev(&
     2999                        ig, lmix(ig) - 1)) - (zlev(ig, lmix(ig))))))
     3000      ELSE
     3001        zmix(ig) = 0.
    4143002      END IF
    415       IF (zw2(ig,l+1)<0.) THEN
    416         zw2(ig, l+1) = 0.
    417         lmaxa(ig) = l
     3003    END DO
     3004
     3005    ! calcul du nouveau lmix correspondant
     3006    DO ig = 1, ngrid
     3007      DO l = 1, klev
     3008        IF (zmix(ig)>=zlev(ig, l) .AND. zmix(ig)<zlev(ig, l + 1)) THEN
     3009          lmix(ig) = l
     3010        END IF
     3011      END DO
     3012    END DO
     3013
     3014    DO l = 2, nlay
     3015      DO ig = 1, ngrid
     3016        IF (larg_cons(ig, l)>1.) THEN
     3017          ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
     3018          fraca(ig, l) = (larg_cons(ig, l) - larg_detr(ig, l)) / (r_aspect * zmax(ig))
     3019          ! test
     3020          fraca(ig, l) = max(fraca(ig, l), 0.)
     3021          fraca(ig, l) = min(fraca(ig, l), 0.5)
     3022          fracd(ig, l) = 1. - fraca(ig, l)
     3023          fracc(ig, l) = larg_cons(ig, l) / (r_aspect * zmax(ig))
     3024        ELSE
     3025          ! wa_moy(ig,l)=0.
     3026          fraca(ig, l) = 0.
     3027          fracc(ig, l) = 0.
     3028          fracd(ig, l) = 1.
     3029        END IF
     3030      END DO
     3031    END DO
     3032    ! CR: calcul de fracazmix
     3033    DO ig = 1, ngrid
     3034      fracazmix(ig) = (fraca(ig, lmix(ig) + 1) - fraca(ig, lmix(ig))) / &
     3035              (zlev(ig, lmix(ig) + 1) - zlev(ig, lmix(ig))) * zmix(ig) + &
     3036              fraca(ig, lmix(ig)) - zlev(ig, lmix(ig)) * (fraca(ig, lmix(ig) + 1) - fraca(ig &
     3037              , lmix(ig))) / (zlev(ig, lmix(ig) + 1) - zlev(ig, lmix(ig)))
     3038    END DO
     3039
     3040    DO l = 2, nlay
     3041      DO ig = 1, ngrid
     3042        IF (larg_cons(ig, l)>1.) THEN
     3043          IF (l>lmix(ig)) THEN
     3044            xxx(ig, l) = (zmax(ig) - zlev(ig, l)) / (zmax(ig) - zmix(ig))
     3045            IF (idetr==0) THEN
     3046              fraca(ig, l) = fracazmix(ig)
     3047            ELSE IF (idetr==1) THEN
     3048              fraca(ig, l) = fracazmix(ig) * xxx(ig, l)
     3049            ELSE IF (idetr==2) THEN
     3050              fraca(ig, l) = fracazmix(ig) * (1. - (1. - xxx(ig, l))**2)
     3051            ELSE
     3052              fraca(ig, l) = fracazmix(ig) * xxx(ig, l)**2
     3053            END IF
     3054            ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
     3055            fraca(ig, l) = max(fraca(ig, l), 0.)
     3056            fraca(ig, l) = min(fraca(ig, l), 0.5)
     3057            fracd(ig, l) = 1. - fraca(ig, l)
     3058            fracc(ig, l) = larg_cons(ig, l) / (r_aspect * zmax(ig))
     3059          END IF
     3060        END IF
     3061      END DO
     3062    END DO
     3063
     3064    ! PRINT*,'11 OK convect8'
     3065    ! PRINT*,'Ea3 ',wa_moy
     3066    ! ------------------------------------------------------------------
     3067    ! Calcul de fracd, wd
     3068    ! somme wa - wd = 0
     3069    ! ------------------------------------------------------------------
     3070
     3071    DO ig = 1, ngrid
     3072      fm(ig, 1) = 0.
     3073      fm(ig, nlay + 1) = 0.
     3074    END DO
     3075
     3076    DO l = 2, nlay
     3077      DO ig = 1, ngrid
     3078        fm(ig, l) = fraca(ig, l) * wa_moy(ig, l) * rhobarz(ig, l)
     3079        ! CR:test
     3080        IF (entr(ig, l - 1)<1E-10 .AND. fm(ig, l)>fm(ig, l - 1) .AND. l>lmix(ig)) THEN
     3081          fm(ig, l) = fm(ig, l - 1)
     3082          ! WRITE(1,*)'ajustement fm, l',l
     3083        END IF
     3084        ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
     3085        ! RC
     3086      END DO
     3087      DO ig = 1, ngrid
     3088        IF (fracd(ig, l)<0.1) THEN
     3089          abort_message = 'fracd trop petit'
     3090          CALL abort_physic(modname, abort_message, 1)
     3091        ELSE
     3092          ! vitesse descendante "diagnostique"
     3093          wd(ig, l) = fm(ig, l) / (fracd(ig, l) * rhobarz(ig, l))
     3094        END IF
     3095      END DO
     3096    END DO
     3097
     3098    DO l = 1, nlay
     3099      DO ig = 1, ngrid
     3100        ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
     3101        masse(ig, l) = (pplev(ig, l) - pplev(ig, l + 1)) / rg
     3102      END DO
     3103    END DO
     3104
     3105    ! PRINT*,'12 OK convect8'
     3106    ! PRINT*,'WA4 ',wa_moy
     3107    ! c------------------------------------------------------------------
     3108    ! calcul du transport vertical
     3109    ! ------------------------------------------------------------------
     3110
     3111    GO TO 4444
     3112    ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
     3113    DO l = 2, nlay - 1
     3114      DO ig = 1, ngrid
     3115        IF (fm(ig, l + 1) * ptimestep>masse(ig, l) .AND. fm(ig, l + 1) * ptimestep>masse(&
     3116                ig, l + 1)) THEN
     3117          ! PRINT*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
     3118          ! s         ,fm(ig,l+1)*ptimestep
     3119          ! s         ,'   M=',masse(ig,l),masse(ig,l+1)
     3120        END IF
     3121      END DO
     3122    END DO
     3123
     3124    DO l = 1, nlay
     3125      DO ig = 1, ngrid
     3126        IF (entr(ig, l) * ptimestep>masse(ig, l)) THEN
     3127          ! PRINT*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
     3128          ! s         ,entr(ig,l)*ptimestep
     3129          ! s         ,'   M=',masse(ig,l)
     3130        END IF
     3131      END DO
     3132    END DO
     3133
     3134    DO l = 1, nlay
     3135      DO ig = 1, ngrid
     3136        IF (.NOT. fm(ig, l)>=0. .OR. .NOT. fm(ig, l)<=10.) THEN
     3137          ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
     3138          ! s         ,'   FM=',fm(ig,l)
     3139        END IF
     3140        IF (.NOT. masse(ig, l)>=1.E-10 .OR. .NOT. masse(ig, l)<=1.E4) THEN
     3141          ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
     3142          ! s         ,'   M=',masse(ig,l)
     3143          ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
     3144          ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
     3145          ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
     3146          ! s                ,zlev(ig,l+1),zlev(ig,l)
     3147          ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
     3148          ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
     3149        END IF
     3150        IF (.NOT. entr(ig, l)>=0. .OR. .NOT. entr(ig, l)<=10.) THEN
     3151          ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
     3152          ! s         ,'   E=',entr(ig,l)
     3153        END IF
     3154      END DO
     3155    END DO
     3156
     3157    4444 CONTINUE
     3158
     3159    IF (w2di==1) THEN
     3160      fm0 = fm0 + ptimestep * (fm - fm0) / tho
     3161      entr0 = entr0 + ptimestep * (entr - entr0) / tho
     3162    ELSE
     3163      fm0 = fm
     3164      entr0 = entr
     3165    END IF
     3166
     3167    IF (1==1) THEN
     3168      ! CALL dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
     3169      ! .    ,zh,zdhadj,zha)
     3170      ! CALL dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
     3171      ! .    ,zo,pdoadj,zoa)
     3172      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zthl, &
     3173              zdthladj, zta)
     3174      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, po, pdoadj, &
     3175              zoa)
     3176    ELSE
     3177      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
     3178              zdhadj, zha)
     3179      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
     3180              pdoadj, zoa)
     3181    END IF
     3182
     3183    IF (1==0) THEN
     3184      CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
     3185              zu, zv, pduadj, pdvadj, zua, zva)
     3186    ELSE
     3187      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
     3188              zua)
     3189      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
     3190              zva)
     3191    END IF
     3192
     3193    DO l = 1, nlay
     3194      DO ig = 1, ngrid
     3195        zf = 0.5 * (fracc(ig, l) + fracc(ig, l + 1))
     3196        zf2 = zf / (1. - zf)
     3197        thetath2(ig, l) = zf2 * (zha(ig, l) - zh(ig, l))**2
     3198        wth2(ig, l) = zf2 * (0.5 * (wa_moy(ig, l) + wa_moy(ig, l + 1)))**2
     3199      END DO
     3200    END DO
     3201
     3202
     3203
     3204    ! PRINT*,'13 OK convect8'
     3205    ! PRINT*,'WA5 ',wa_moy
     3206    DO l = 1, nlay
     3207      DO ig = 1, ngrid
     3208        ! pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
     3209        pdtadj(ig, l) = zdthladj(ig, l) * zpspsk(ig, l)
     3210      END DO
     3211    END DO
     3212
     3213
     3214    ! do l=1,nlay
     3215    ! do ig=1,ngrid
     3216    ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
     3217    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     3218    ! s         ,'   pdtadj=',pdtadj(ig,l)
     3219    ! END IF
     3220    ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
     3221    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     3222    ! s         ,'   pdoadj=',pdoadj(ig,l)
     3223    ! END IF
     3224    ! enddo
     3225    ! enddo
     3226
     3227    ! PRINT*,'14 OK convect8'
     3228    ! ------------------------------------------------------------------
     3229    ! Calculs pour les sorties
     3230    ! ------------------------------------------------------------------
     3231
     3232  END SUBROUTINE thermcell_eau
     3233
     3234  SUBROUTINE thermcell(ngrid, nlay, ptimestep, pplay, pplev, pphi, pu, pv, pt, &
     3235          po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s
     3236          ! ,pu_therm,pv_therm
     3237          , r_aspect, l_mix, w2di, tho)
     3238
     3239    USE dimphy
     3240    IMPLICIT NONE
     3241
     3242    ! =======================================================================
     3243
     3244    ! Calcul du transport verticale dans la couche limite en presence
     3245    ! de "thermiques" explicitement representes
     3246
     3247    ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
     3248
     3249    ! le thermique est supposé homogène et dissipé par mélange avec
     3250    ! son environnement. la longueur l_mix contrôle l'efficacité du
     3251    ! mélange
     3252
     3253    ! Le calcul du transport des différentes espèces se fait en prenant
     3254    ! en compte:
     3255    ! 1. un flux de masse montant
     3256    ! 2. un flux de masse descendant
     3257    ! 3. un entrainement
     3258    ! 4. un detrainement
     3259
     3260    ! =======================================================================
     3261
     3262    ! -----------------------------------------------------------------------
     3263    ! declarations:
     3264    ! -------------
     3265
     3266    include "YOMCST.h"
     3267
     3268    ! arguments:
     3269    ! ----------
     3270
     3271    INTEGER ngrid, nlay, w2di
     3272    REAL tho
     3273    REAL ptimestep, l_mix, r_aspect
     3274    REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
     3275    REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
     3276    REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
     3277    REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
     3278    REAL pplay(ngrid, nlay), pplev(ngrid, nlay + 1)
     3279    REAL pphi(ngrid, nlay)
     3280
     3281    INTEGER idetr
     3282    SAVE idetr
     3283    DATA idetr/3/
     3284    !$OMP THREADPRIVATE(idetr)
     3285
     3286    ! local:
     3287    ! ------
     3288
     3289    INTEGER ig, k, l, lmaxa(klon), lmix(klon)
     3290    REAL zsortie1d(klon)
     3291    ! CR: on remplace lmax(klon,klev+1)
     3292    INTEGER lmax(klon), lmin(klon), lentr(klon)
     3293    REAL linter(klon)
     3294    REAL zmix(klon), fracazmix(klon)
     3295    ! RC
     3296    REAL zmax(klon), zw, zz, zw2(klon, klev + 1), ztva(klon, klev), zzz
     3297
     3298    REAL zlev(klon, klev + 1), zlay(klon, klev)
     3299    REAL zh(klon, klev), zdhadj(klon, klev)
     3300    REAL ztv(klon, klev)
     3301    REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
     3302    REAL wh(klon, klev + 1)
     3303    REAL wu(klon, klev + 1), wv(klon, klev + 1), wo(klon, klev + 1)
     3304    REAL zla(klon, klev + 1)
     3305    REAL zwa(klon, klev + 1)
     3306    REAL zld(klon, klev + 1)
     3307    REAL zwd(klon, klev + 1)
     3308    REAL zsortie(klon, klev)
     3309    REAL zva(klon, klev)
     3310    REAL zua(klon, klev)
     3311    REAL zoa(klon, klev)
     3312
     3313    REAL zha(klon, klev)
     3314    REAL wa_moy(klon, klev + 1)
     3315    REAL fraca(klon, klev + 1)
     3316    REAL fracc(klon, klev + 1)
     3317    REAL zf, zf2
     3318    REAL thetath2(klon, klev), wth2(klon, klev)
     3319    ! common/comtherm/thetath2,wth2
     3320
     3321    REAL count_time
     3322    INTEGER ialt
     3323
     3324    LOGICAL sorties
     3325    REAL rho(klon, klev), rhobarz(klon, klev + 1), masse(klon, klev)
     3326    REAL zpspsk(klon, klev)
     3327
     3328    ! real wmax(klon,klev),wmaxa(klon)
     3329    REAL wmax(klon), wmaxa(klon)
     3330    REAL wa(klon, klev, klev + 1)
     3331    REAL wd(klon, klev + 1)
     3332    REAL larg_part(klon, klev, klev + 1)
     3333    REAL fracd(klon, klev + 1)
     3334    REAL xxx(klon, klev + 1)
     3335    REAL larg_cons(klon, klev + 1)
     3336    REAL larg_detr(klon, klev + 1)
     3337    REAL fm0(klon, klev + 1), entr0(klon, klev), detr(klon, klev)
     3338    REAL pu_therm(klon, klev), pv_therm(klon, klev)
     3339    REAL fm(klon, klev + 1), entr(klon, klev)
     3340    REAL fmc(klon, klev + 1)
     3341
     3342    ! CR:nouvelles variables
     3343    REAL f_star(klon, klev + 1), entr_star(klon, klev)
     3344    REAL entr_star_tot(klon), entr_star2(klon)
     3345    REAL f(klon), f0(klon)
     3346    REAL zlevinter(klon)
     3347    LOGICAL first
     3348    DATA first/.FALSE./
     3349    SAVE first
     3350    !$OMP THREADPRIVATE(first)
     3351    ! RC
     3352
     3353    CHARACTER *2 str2
     3354    CHARACTER *10 str10
     3355
     3356    CHARACTER (LEN = 20) :: modname = 'thermcell'
     3357    CHARACTER (LEN = 80) :: abort_message
     3358
     3359    LOGICAL vtest(klon), down
     3360
     3361    INTEGER ncorrec, ll
     3362    SAVE ncorrec
     3363    DATA ncorrec/0/
     3364    !$OMP THREADPRIVATE(ncorrec)
     3365
     3366
     3367    ! -----------------------------------------------------------------------
     3368    ! initialisation:
     3369    ! ---------------
     3370
     3371    sorties = .TRUE.
     3372    IF (ngrid/=klon) THEN
     3373      PRINT *
     3374      PRINT *, 'STOP dans convadj'
     3375      PRINT *, 'ngrid    =', ngrid
     3376      PRINT *, 'klon  =', klon
     3377    END IF
     3378
     3379    ! -----------------------------------------------------------------------
     3380    ! incrementation eventuelle de tendances precedentes:
     3381    ! ---------------------------------------------------
     3382
     3383    ! PRINT*,'0 OK convect8'
     3384
     3385    DO l = 1, nlay
     3386      DO ig = 1, ngrid
     3387        zpspsk(ig, l) = (pplay(ig, l) / pplev(ig, 1))**rkappa
     3388        zh(ig, l) = pt(ig, l) / zpspsk(ig, l)
     3389        zu(ig, l) = pu(ig, l)
     3390        zv(ig, l) = pv(ig, l)
     3391        zo(ig, l) = po(ig, l)
     3392        ztv(ig, l) = zh(ig, l) * (1. + 0.61 * zo(ig, l))
     3393      END DO
     3394    END DO
     3395
     3396    ! PRINT*,'1 OK convect8'
     3397    ! --------------------
     3398
     3399
     3400    ! + + + + + + + + + + +
     3401
     3402
     3403    ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
     3404    ! wh,wt,wo ...
     3405
     3406    ! + + + + + + + + + + +  zh,zu,zv,zo,rho
     3407
     3408
     3409    ! --------------------   zlev(1)
     3410    ! \\\\\\\\\\\\\\\\\\\\
     3411
     3412
     3413
     3414    ! -----------------------------------------------------------------------
     3415    ! Calcul des altitudes des couches
     3416    ! -----------------------------------------------------------------------
     3417
     3418    DO l = 2, nlay
     3419      DO ig = 1, ngrid
     3420        zlev(ig, l) = 0.5 * (pphi(ig, l) + pphi(ig, l - 1)) / rg
     3421      END DO
     3422    END DO
     3423    DO ig = 1, ngrid
     3424      zlev(ig, 1) = 0.
     3425      zlev(ig, nlay + 1) = (2. * pphi(ig, klev) - pphi(ig, klev - 1)) / rg
     3426    END DO
     3427    DO l = 1, nlay
     3428      DO ig = 1, ngrid
     3429        zlay(ig, l) = pphi(ig, l) / rg
     3430      END DO
     3431    END DO
     3432
     3433    ! PRINT*,'2 OK convect8'
     3434    ! -----------------------------------------------------------------------
     3435    ! Calcul des densites
     3436    ! -----------------------------------------------------------------------
     3437
     3438    DO l = 1, nlay
     3439      DO ig = 1, ngrid
     3440        rho(ig, l) = pplay(ig, l) / (zpspsk(ig, l) * rd * zh(ig, l))
     3441      END DO
     3442    END DO
     3443
     3444    DO l = 2, nlay
     3445      DO ig = 1, ngrid
     3446        rhobarz(ig, l) = 0.5 * (rho(ig, l) + rho(ig, l - 1))
     3447      END DO
     3448    END DO
     3449
     3450    DO k = 1, nlay
     3451      DO l = 1, nlay + 1
     3452        DO ig = 1, ngrid
     3453          wa(ig, k, l) = 0.
     3454        END DO
     3455      END DO
     3456    END DO
     3457
     3458    ! PRINT*,'3 OK convect8'
     3459    ! ------------------------------------------------------------------
     3460    ! Calcul de w2, quarre de w a partir de la cape
     3461    ! a partir de w2, on calcule wa, vitesse de l'ascendance
     3462
     3463    ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
     3464    ! w2 est stoke dans wa
     3465
     3466    ! ATTENTION: dans convect8, on n'utilise le calcule des wa
     3467    ! independants par couches que pour calculer l'entrainement
     3468    ! a la base et la hauteur max de l'ascendance.
     3469
     3470    ! Indicages:
     3471    ! l'ascendance provenant du niveau k traverse l'interface l avec
     3472    ! une vitesse wa(k,l).
     3473
     3474    ! --------------------
     3475
     3476    ! + + + + + + + + + +
     3477
     3478    ! wa(k,l)   ----       --------------------    l
     3479    ! /\
     3480    ! /||\       + + + + + + + + + +
     3481    ! ||
     3482    ! ||        --------------------
     3483    ! ||
     3484    ! ||        + + + + + + + + + +
     3485    ! ||
     3486    ! ||        --------------------
     3487    ! ||__
     3488    ! |___      + + + + + + + + + +     k
     3489
     3490    ! --------------------
     3491
     3492
     3493
     3494    ! ------------------------------------------------------------------
     3495
     3496    ! CR: ponderation entrainement des couches instables
     3497    ! def des entr_star tels que entr=f*entr_star
     3498    DO l = 1, klev
     3499      DO ig = 1, ngrid
     3500        entr_star(ig, l) = 0.
     3501      END DO
     3502    END DO
     3503    ! determination de la longueur de la couche d entrainement
     3504    DO ig = 1, ngrid
     3505      lentr(ig) = 1
     3506    END DO
     3507
     3508    ! on ne considere que les premieres couches instables
     3509    DO k = nlay - 2, 1, -1
     3510      DO ig = 1, ngrid
     3511        IF (ztv(ig, k)>ztv(ig, k + 1) .AND. ztv(ig, k + 1)<=ztv(ig, k + 2)) THEN
     3512          lentr(ig) = k
     3513        END IF
     3514      END DO
     3515    END DO
     3516
     3517    ! determination du lmin: couche d ou provient le thermique
     3518    DO ig = 1, ngrid
     3519      lmin(ig) = 1
     3520    END DO
     3521    DO ig = 1, ngrid
     3522      DO l = nlay, 2, -1
     3523        IF (ztv(ig, l - 1)>ztv(ig, l)) THEN
     3524          lmin(ig) = l - 1
     3525        END IF
     3526      END DO
     3527    END DO
     3528
     3529    ! definition de l'entrainement des couches
     3530    DO l = 1, klev - 1
     3531      DO ig = 1, ngrid
     3532        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN
     3533          entr_star(ig, l) = (ztv(ig, l) - ztv(ig, l + 1)) * (zlev(ig, l + 1) - zlev(ig, l))
     3534        END IF
     3535      END DO
     3536    END DO
     3537    ! pas de thermique si couches 1->5 stables
     3538    DO ig = 1, ngrid
     3539      IF (lmin(ig)>5) THEN
     3540        DO l = 1, klev
     3541          entr_star(ig, l) = 0.
     3542        END DO
     3543      END IF
     3544    END DO
     3545    ! calcul de l entrainement total
     3546    DO ig = 1, ngrid
     3547      entr_star_tot(ig) = 0.
     3548    END DO
     3549    DO ig = 1, ngrid
     3550      DO k = 1, klev
     3551        entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k)
     3552      END DO
     3553    END DO
     3554
     3555    PRINT *, 'fin calcul entr_star'
     3556    DO k = 1, klev
     3557      DO ig = 1, ngrid
     3558        ztva(ig, k) = ztv(ig, k)
     3559      END DO
     3560    END DO
     3561    ! RC
     3562    ! PRINT*,'7 OK convect8'
     3563    DO k = 1, klev + 1
     3564      DO ig = 1, ngrid
     3565        zw2(ig, k) = 0.
     3566        fmc(ig, k) = 0.
     3567        ! CR
     3568        f_star(ig, k) = 0.
     3569        ! RC
     3570        larg_cons(ig, k) = 0.
     3571        larg_detr(ig, k) = 0.
     3572        wa_moy(ig, k) = 0.
     3573      END DO
     3574    END DO
     3575
     3576    ! PRINT*,'8 OK convect8'
     3577    DO ig = 1, ngrid
     3578      linter(ig) = 1.
     3579      lmaxa(ig) = 1
     3580      lmix(ig) = 1
     3581      wmaxa(ig) = 0.
     3582    END DO
     3583
     3584    ! CR:
     3585    DO l = 1, nlay - 2
     3586      DO ig = 1, ngrid
     3587        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. entr_star(ig, l)>1.E-10 .AND. &
     3588                zw2(ig, l)<1E-10) THEN
     3589          f_star(ig, l + 1) = entr_star(ig, l)
     3590          ! test:calcul de dteta
     3591          zw2(ig, l + 1) = 2. * rg * (ztv(ig, l) - ztv(ig, l + 1)) / ztv(ig, l + 1) * &
     3592                  (zlev(ig, l + 1) - zlev(ig, l)) * 0.4 * pphi(ig, l) / (pphi(ig, l + 1) - pphi(ig, l))
     3593          larg_detr(ig, l) = 0.
     3594        ELSE IF ((zw2(ig, l)>=1E-10) .AND. (f_star(ig, l) + entr_star(ig, &
     3595                l)>1.E-10)) THEN
     3596          f_star(ig, l + 1) = f_star(ig, l) + entr_star(ig, l)
     3597          ztva(ig, l) = (f_star(ig, l) * ztva(ig, l - 1) + entr_star(ig, l) * ztv(ig, l)) / &
     3598                  f_star(ig, l + 1)
     3599          zw2(ig, l + 1) = zw2(ig, l) * (f_star(ig, l) / f_star(ig, l + 1))**2 + &
     3600                  2. * rg * (ztva(ig, l) - ztv(ig, l)) / ztv(ig, l) * (zlev(ig, l + 1) - zlev(ig, l))
     3601        END IF
     3602        ! determination de zmax continu par interpolation lineaire
     3603        IF (zw2(ig, l + 1)<0.) THEN
     3604          ! test
     3605          IF (abs(zw2(ig, l + 1) - zw2(ig, l))<1E-10) THEN
     3606            PRINT *, 'pb linter'
     3607          END IF
     3608          linter(ig) = (l * (zw2(ig, l + 1) - zw2(ig, l)) - zw2(ig, l)) / (zw2(ig, l + 1) - zw2(&
     3609                  ig, l))
     3610          zw2(ig, l + 1) = 0.
     3611          lmaxa(ig) = l
     3612        ELSE
     3613          IF (zw2(ig, l + 1)<0.) THEN
     3614            PRINT *, 'pb1 zw2<0'
     3615          END IF
     3616          wa_moy(ig, l + 1) = sqrt(zw2(ig, l + 1))
     3617        END IF
     3618        IF (wa_moy(ig, l + 1)>wmaxa(ig)) THEN
     3619          ! lmix est le niveau de la couche ou w (wa_moy) est maximum
     3620          lmix(ig) = l + 1
     3621          wmaxa(ig) = wa_moy(ig, l + 1)
     3622        END IF
     3623      END DO
     3624    END DO
     3625    PRINT *, 'fin calcul zw2'
     3626
     3627    ! Calcul de la couche correspondant a la hauteur du thermique
     3628    DO ig = 1, ngrid
     3629      lmax(ig) = lentr(ig)
     3630    END DO
     3631    DO ig = 1, ngrid
     3632      DO l = nlay, lentr(ig) + 1, -1
     3633        IF (zw2(ig, l)<=1.E-10) THEN
     3634          lmax(ig) = l - 1
     3635        END IF
     3636      END DO
     3637    END DO
     3638    ! pas de thermique si couches 1->5 stables
     3639    DO ig = 1, ngrid
     3640      IF (lmin(ig)>5) THEN
     3641        lmax(ig) = 1
     3642        lmin(ig) = 1
     3643      END IF
     3644    END DO
     3645
     3646    ! Determination de zw2 max
     3647    DO ig = 1, ngrid
     3648      wmax(ig) = 0.
     3649    END DO
     3650
     3651    DO l = 1, nlay
     3652      DO ig = 1, ngrid
     3653        IF (l<=lmax(ig)) THEN
     3654          IF (zw2(ig, l)<0.) THEN
     3655            PRINT *, 'pb2 zw2<0'
     3656          END IF
     3657          zw2(ig, l) = sqrt(zw2(ig, l))
     3658          wmax(ig) = max(wmax(ig), zw2(ig, l))
     3659        ELSE
     3660          zw2(ig, l) = 0.
     3661        END IF
     3662      END DO
     3663    END DO
     3664
     3665    ! Longueur caracteristique correspondant a la hauteur des thermiques.
     3666    DO ig = 1, ngrid
     3667      zmax(ig) = 0.
     3668      zlevinter(ig) = zlev(ig, 1)
     3669    END DO
     3670    DO ig = 1, ngrid
     3671      ! calcul de zlevinter
     3672      zlevinter(ig) = (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig))) * linter(ig) + &
     3673              zlev(ig, lmax(ig)) - lmax(ig) * (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig)))
     3674      zmax(ig) = max(zmax(ig), zlevinter(ig) - zlev(ig, lmin(ig)))
     3675    END DO
     3676
     3677    PRINT *, 'avant fermeture'
     3678    ! Fermeture,determination de f
     3679    DO ig = 1, ngrid
     3680      entr_star2(ig) = 0.
     3681    END DO
     3682    DO ig = 1, ngrid
     3683      IF (entr_star_tot(ig)<1.E-10) THEN
     3684        f(ig) = 0.
    4183685      ELSE
    419         wa_moy(ig, l+1) = sqrt(zw2(ig,l+1))
    420       END IF
    421       IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN
    422         ! lmix est le niveau de la couche ou w (wa_moy) est maximum
    423         lmix(ig) = l + 1
    424         wmaxa(ig) = wa_moy(ig, l+1)
    425       END IF
    426       ! PRINT*,'COUCOU cas 2 LMIX=',lmix(ig),wa_moy(ig,l+1),wmaxa(ig)
    427     END DO
    428   END DO
    429 
    430   ! PRINT*,'9 OK convect8'
    431   ! PRINT*,'WA1 ',wa_moy
    432 
    433   ! determination de l'indice du debut de la mixed layer ou w decroit
    434 
    435   ! calcul de la largeur de chaque ascendance dans le cas conservatif.
    436   ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
    437   ! d'une couche est égale à la hauteur de la couche alimentante.
    438   ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
    439   ! de la vitesse d'entrainement horizontal dans la couche alimentante.
    440 
    441   ! PRINT*,'OKl439'
    442   DO l = 2, nlay
    443     DO ig = 1, ngrid
    444       IF (l<=lmaxa(ig)) THEN
    445         zw = max(wa_moy(ig,l), 1.E-10)
    446         larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw)
    447       END IF
    448     END DO
    449   END DO
    450 
    451   DO l = 2, nlay
    452     DO ig = 1, ngrid
    453       IF (l<=lmaxa(ig)) THEN
    454         ! if (idetr.EQ.0) THEN
    455         ! cette option est finalement en dur.
    456         larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l))
    457         ! ELSE IF (idetr.EQ.1) THEN
    458         ! larg_detr(ig,l)=larg_cons(ig,l)
    459         ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
    460         ! ELSE IF (idetr.EQ.2) THEN
    461         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    462         ! s            *sqrt(wa_moy(ig,l))
    463         ! ELSE IF (idetr.EQ.4) THEN
    464         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    465         ! s            *wa_moy(ig,l)
     3686        DO k = lmin(ig), lentr(ig)
     3687          entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2 / (rho(ig, k) * (&
     3688                  zlev(ig, k + 1) - zlev(ig, k)))
     3689        END DO
     3690        ! Nouvelle fermeture
     3691        f(ig) = wmax(ig) / (max(500., zmax(ig)) * r_aspect * entr_star2(ig)) * &
     3692                entr_star_tot(ig)
     3693        ! test
     3694        ! if (first) THEN
     3695        ! f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
     3696        ! s             *wmax(ig))
    4663697        ! END IF
    4673698      END IF
    468     END DO
    469   END DO
    470 
    471   ! PRINT*,'10 OK convect8'
    472   ! PRINT*,'WA2 ',wa_moy
    473   ! calcul de la fraction de la maille concernée par l'ascendance en tenant
    474   ! compte de l'epluchage du thermique.
    475 
    476   DO l = 2, nlay
    477     DO ig = 1, ngrid
    478       IF (larg_cons(ig,l)>1.) THEN
    479         ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
    480         fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig))
    481         IF (l>lmix(ig)) THEN
    482           xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
    483           IF (idetr==0) THEN
    484             fraca(ig, l) = fraca(ig, lmix(ig))
    485           ELSE IF (idetr==1) THEN
    486             fraca(ig, l) = fraca(ig, lmix(ig))*xxx(ig, l)
    487           ELSE IF (idetr==2) THEN
    488             fraca(ig, l) = fraca(ig, lmix(ig))*(1.-(1.-xxx(ig,l))**2)
    489           ELSE
    490             fraca(ig, l) = fraca(ig, lmix(ig))*xxx(ig, l)**2
     3699      ! f0(ig)=f(ig)
     3700      ! first=.TRUE.
     3701    END DO
     3702    PRINT *, 'apres fermeture'
     3703
     3704    ! Calcul de l'entrainement
     3705    DO k = 1, klev
     3706      DO ig = 1, ngrid
     3707        entr(ig, k) = f(ig) * entr_star(ig, k)
     3708      END DO
     3709    END DO
     3710    ! Calcul des flux
     3711    DO ig = 1, ngrid
     3712      DO l = 1, lmax(ig) - 1
     3713        fmc(ig, l + 1) = fmc(ig, l) + entr(ig, l)
     3714      END DO
     3715    END DO
     3716
     3717    ! RC
     3718
     3719
     3720    ! PRINT*,'9 OK convect8'
     3721    ! PRINT*,'WA1 ',wa_moy
     3722
     3723    ! determination de l'indice du debut de la mixed layer ou w decroit
     3724
     3725    ! calcul de la largeur de chaque ascendance dans le cas conservatif.
     3726    ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
     3727    ! d'une couche est égale à la hauteur de la couche alimentante.
     3728    ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
     3729    ! de la vitesse d'entrainement horizontal dans la couche alimentante.
     3730
     3731    DO l = 2, nlay
     3732      DO ig = 1, ngrid
     3733        IF (l<=lmaxa(ig)) THEN
     3734          zw = max(wa_moy(ig, l), 1.E-10)
     3735          larg_cons(ig, l) = zmax(ig) * r_aspect * fmc(ig, l) / (rhobarz(ig, l) * zw)
     3736        END IF
     3737      END DO
     3738    END DO
     3739
     3740    DO l = 2, nlay
     3741      DO ig = 1, ngrid
     3742        IF (l<=lmaxa(ig)) THEN
     3743          ! if (idetr.EQ.0) THEN
     3744          ! cette option est finalement en dur.
     3745          IF ((l_mix * zlev(ig, l))<0.) THEN
     3746            PRINT *, 'pb l_mix*zlev<0'
    4913747          END IF
    492         END IF
    493         ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
    494         fraca(ig, l) = max(fraca(ig,l), 0.)
    495         fraca(ig, l) = min(fraca(ig,l), 0.5)
    496         fracd(ig, l) = 1. - fraca(ig, l)
    497         fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig))
     3748          larg_detr(ig, l) = sqrt(l_mix * zlev(ig, l))
     3749          ! ELSE IF (idetr.EQ.1) THEN
     3750          ! larg_detr(ig,l)=larg_cons(ig,l)
     3751          ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
     3752          ! ELSE IF (idetr.EQ.2) THEN
     3753          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     3754          ! s            *sqrt(wa_moy(ig,l))
     3755          ! ELSE IF (idetr.EQ.4) THEN
     3756          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     3757          ! s            *wa_moy(ig,l)
     3758          ! END IF
     3759        END IF
     3760      END DO
     3761    END DO
     3762
     3763    ! PRINT*,'10 OK convect8'
     3764    ! PRINT*,'WA2 ',wa_moy
     3765    ! calcul de la fraction de la maille concernée par l'ascendance en tenant
     3766    ! compte de l'epluchage du thermique.
     3767
     3768    ! CR def de  zmix continu (profil parabolique des vitesses)
     3769    DO ig = 1, ngrid
     3770      IF (lmix(ig)>1.) THEN
     3771        ! test
     3772        IF (((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig))) - &
     3773                (zlev(ig, lmix(ig) + 1))) - (zw2(ig, lmix(ig)) - &
     3774                zw2(ig, lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1)) - &
     3775                (zlev(ig, lmix(ig)))))>1E-10) THEN
     3776
     3777          zmix(ig) = ((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig)) &
     3778                  )**2 - (zlev(ig, lmix(ig) + 1))**2) - (zw2(ig, lmix(ig)) - zw2(ig, &
     3779                  lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1))**2 - (zlev(ig, lmix(ig)))**2)) / &
     3780                  (2. * ((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig))) - &
     3781                          (zlev(ig, lmix(ig) + 1))) - (zw2(ig, lmix(ig)) - &
     3782                          zw2(ig, lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1)) - (zlev(ig, lmix(ig))))))
     3783        ELSE
     3784          zmix(ig) = zlev(ig, lmix(ig))
     3785          PRINT *, 'pb zmix'
     3786        END IF
    4983787      ELSE
    499         ! wa_moy(ig,l)=0.
    500         fraca(ig, l) = 0.
    501         fracc(ig, l) = 0.
    502         fracd(ig, l) = 1.
     3788        zmix(ig) = 0.
    5033789      END IF
    504     END DO
    505   END DO
    506 
    507   ! PRINT*,'11 OK convect8'
    508   ! PRINT*,'Ea3 ',wa_moy
    509   ! ------------------------------------------------------------------
    510   ! Calcul de fracd, wd
    511   ! somme wa - wd = 0
    512   ! ------------------------------------------------------------------
    513 
    514 
    515   DO ig = 1, ngrid
    516     fm(ig, 1) = 0.
    517     fm(ig, nlay+1) = 0.
    518   END DO
    519 
    520   DO l = 2, nlay
    521     DO ig = 1, ngrid
    522       fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l)
    523     END DO
    524     DO ig = 1, ngrid
    525       IF (fracd(ig,l)<0.1) THEN
    526         abort_message = 'fracd trop petit'
    527         CALL abort_physic(modname, abort_message, 1)
    528       ELSE
    529         ! vitesse descendante "diagnostique"
    530         wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l))
     3790      ! test
     3791      IF ((zmax(ig) - zmix(ig))<0.) THEN
     3792        zmix(ig) = 0.99 * zmax(ig)
     3793        ! PRINT*,'pb zmix>zmax'
    5313794      END IF
    5323795    END DO
    533   END DO
    534 
    535   DO l = 1, nlay
    536     DO ig = 1, ngrid
    537       ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    538       masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg
    539     END DO
    540   END DO
    541 
    542   ! PRINT*,'12 OK convect8'
    543   ! PRINT*,'WA4 ',wa_moy
    544   ! c------------------------------------------------------------------
    545   ! calcul du transport vertical
    546   ! ------------------------------------------------------------------
    547 
    548   GO TO 4444
    549   ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
    550   DO l = 2, nlay - 1
    551     DO ig = 1, ngrid
    552       IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( &
    553           ig,l+1)) THEN
    554         ! PRINT*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
    555         ! s         ,fm(ig,l+1)*ptimestep
    556         ! s         ,'   M=',masse(ig,l),masse(ig,l+1)
    557       END IF
    558     END DO
    559   END DO
    560 
    561   DO l = 1, nlay
    562     DO ig = 1, ngrid
    563       IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN
    564         ! PRINT*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
    565         ! s         ,entr(ig,l)*ptimestep
    566         ! s         ,'   M=',masse(ig,l)
    567       END IF
    568     END DO
    569   END DO
    570 
    571   DO l = 1, nlay
    572     DO ig = 1, ngrid
    573       IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN
    574         ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
    575         ! s         ,'   FM=',fm(ig,l)
    576       END IF
    577       IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN
    578         ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
    579         ! s         ,'   M=',masse(ig,l)
    580         ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
    581         ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
    582         ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
    583         ! s                ,zlev(ig,l+1),zlev(ig,l)
    584         ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
    585         ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
    586       END IF
    587       IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN
    588         ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
    589         ! s         ,'   E=',entr(ig,l)
    590       END IF
    591     END DO
    592   END DO
    593 
    594 4444 CONTINUE
    595   ! PRINT*,'OK 444 '
    596 
    597   IF (w2di==1) THEN
    598     fm0 = fm0 + ptimestep*(fm-fm0)/tho
    599     entr0 = entr0 + ptimestep*(entr-entr0)/tho
    600   ELSE
    601     fm0 = fm
    602     entr0 = entr
    603   END IF
    604 
    605   IF (flagdq==0) THEN
    606     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, &
    607       zha)
    608     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, &
    609       zoa)
    610     PRINT *, 'THERMALS OPT 1'
    611   ELSE IF (flagdq==1) THEN
    612     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
    613       zdhadj, zha)
    614     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
    615       pdoadj, zoa)
    616     PRINT *, 'THERMALS OPT 2'
    617   ELSE
    618     CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zh, &
    619       zdhadj, zha, lev_out)
    620     CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zo, &
    621       pdoadj, zoa, lev_out)
    622     PRINT *, 'THERMALS OPT 3', dqimpl
    623   END IF
    624 
    625   PRINT *, 'TH VENT ', dvdq
    626   IF (dvdq==0) THEN
    627     ! PRINT*,'TH VENT OK ',dvdq
    628     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
    629       zua)
    630     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
    631       zva)
    632   ELSE IF (dvdq==1) THEN
    633     CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
    634       zu, zv, pduadj, pdvadj, zua, zva)
    635   ELSE IF (dvdq==2) THEN
    636     CALL thermcell_dv2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, &
    637       zmax, zu, zv, pduadj, pdvadj, zua, zva, lev_out)
    638   ELSE IF (dvdq==3) THEN
    639     CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zu, &
    640       pduadj, zua, lev_out)
    641     CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zv, &
    642       pdvadj, zva, lev_out)
    643   END IF
    644 
    645   ! CALL writefield_phy('duadj',pduadj,klev)
    646 
    647   DO l = 1, nlay
    648     DO ig = 1, ngrid
    649       zf = 0.5*(fracc(ig,l)+fracc(ig,l+1))
    650       zf2 = zf/(1.-zf)
    651       thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2
    652       wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
    653     END DO
    654   END DO
    655 
    656 
    657 
    658   ! PRINT*,'13 OK convect8'
    659   ! PRINT*,'WA5 ',wa_moy
    660   DO l = 1, nlay
    661     DO ig = 1, ngrid
    662       pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l)
    663     END DO
    664   END DO
    665 
    666 
    667   ! do l=1,nlay
    668   ! do ig=1,ngrid
    669   ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
    670   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    671   ! s         ,'   pdtadj=',pdtadj(ig,l)
    672   ! END IF
    673   ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
    674   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    675   ! s         ,'   pdoadj=',pdoadj(ig,l)
    676   ! END IF
    677   ! enddo
    678   ! enddo
    679 
    680   ! PRINT*,'14 OK convect8'
    681   ! ------------------------------------------------------------------
    682   ! Calculs pour les sorties
    683   ! ------------------------------------------------------------------
    684 
    685   IF (sorties) THEN
     3796
     3797    ! calcul du nouveau lmix correspondant
     3798    DO ig = 1, ngrid
     3799      DO l = 1, klev
     3800        IF (zmix(ig)>=zlev(ig, l) .AND. zmix(ig)<zlev(ig, l + 1)) THEN
     3801          lmix(ig) = l
     3802        END IF
     3803      END DO
     3804    END DO
     3805
     3806    DO l = 2, nlay
     3807      DO ig = 1, ngrid
     3808        IF (larg_cons(ig, l)>1.) THEN
     3809          ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
     3810          fraca(ig, l) = (larg_cons(ig, l) - larg_detr(ig, l)) / (r_aspect * zmax(ig))
     3811          ! test
     3812          fraca(ig, l) = max(fraca(ig, l), 0.)
     3813          fraca(ig, l) = min(fraca(ig, l), 0.5)
     3814          fracd(ig, l) = 1. - fraca(ig, l)
     3815          fracc(ig, l) = larg_cons(ig, l) / (r_aspect * zmax(ig))
     3816        ELSE
     3817          ! wa_moy(ig,l)=0.
     3818          fraca(ig, l) = 0.
     3819          fracc(ig, l) = 0.
     3820          fracd(ig, l) = 1.
     3821        END IF
     3822      END DO
     3823    END DO
     3824    ! CR: calcul de fracazmix
     3825    DO ig = 1, ngrid
     3826      fracazmix(ig) = (fraca(ig, lmix(ig) + 1) - fraca(ig, lmix(ig))) / &
     3827              (zlev(ig, lmix(ig) + 1) - zlev(ig, lmix(ig))) * zmix(ig) + &
     3828              fraca(ig, lmix(ig)) - zlev(ig, lmix(ig)) * (fraca(ig, lmix(ig) + 1) - fraca(ig &
     3829              , lmix(ig))) / (zlev(ig, lmix(ig) + 1) - zlev(ig, lmix(ig)))
     3830    END DO
     3831
     3832    DO l = 2, nlay
     3833      DO ig = 1, ngrid
     3834        IF (larg_cons(ig, l)>1.) THEN
     3835          IF (l>lmix(ig)) THEN
     3836            ! test
     3837            IF (zmax(ig) - zmix(ig)<1.E-10) THEN
     3838              ! PRINT*,'pb xxx'
     3839              xxx(ig, l) = (lmaxa(ig) + 1. - l) / (lmaxa(ig) + 1. - lmix(ig))
     3840            ELSE
     3841              xxx(ig, l) = (zmax(ig) - zlev(ig, l)) / (zmax(ig) - zmix(ig))
     3842            END IF
     3843            IF (idetr==0) THEN
     3844              fraca(ig, l) = fracazmix(ig)
     3845            ELSE IF (idetr==1) THEN
     3846              fraca(ig, l) = fracazmix(ig) * xxx(ig, l)
     3847            ELSE IF (idetr==2) THEN
     3848              fraca(ig, l) = fracazmix(ig) * (1. - (1. - xxx(ig, l))**2)
     3849            ELSE
     3850              fraca(ig, l) = fracazmix(ig) * xxx(ig, l)**2
     3851            END IF
     3852            ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
     3853            fraca(ig, l) = max(fraca(ig, l), 0.)
     3854            fraca(ig, l) = min(fraca(ig, l), 0.5)
     3855            fracd(ig, l) = 1. - fraca(ig, l)
     3856            fracc(ig, l) = larg_cons(ig, l) / (r_aspect * zmax(ig))
     3857          END IF
     3858        END IF
     3859      END DO
     3860    END DO
     3861
     3862    PRINT *, 'fin calcul fraca'
     3863    ! PRINT*,'11 OK convect8'
     3864    ! PRINT*,'Ea3 ',wa_moy
     3865    ! ------------------------------------------------------------------
     3866    ! Calcul de fracd, wd
     3867    ! somme wa - wd = 0
     3868    ! ------------------------------------------------------------------
     3869
     3870    DO ig = 1, ngrid
     3871      fm(ig, 1) = 0.
     3872      fm(ig, nlay + 1) = 0.
     3873    END DO
     3874
     3875    DO l = 2, nlay
     3876      DO ig = 1, ngrid
     3877        fm(ig, l) = fraca(ig, l) * wa_moy(ig, l) * rhobarz(ig, l)
     3878        ! CR:test
     3879        IF (entr(ig, l - 1)<1E-10 .AND. fm(ig, l)>fm(ig, l - 1) .AND. l>lmix(ig)) THEN
     3880          fm(ig, l) = fm(ig, l - 1)
     3881          ! WRITE(1,*)'ajustement fm, l',l
     3882        END IF
     3883        ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
     3884        ! RC
     3885      END DO
     3886      DO ig = 1, ngrid
     3887        IF (fracd(ig, l)<0.1) THEN
     3888          abort_message = 'fracd trop petit'
     3889          CALL abort_physic(modname, abort_message, 1)
     3890        ELSE
     3891          ! vitesse descendante "diagnostique"
     3892          wd(ig, l) = fm(ig, l) / (fracd(ig, l) * rhobarz(ig, l))
     3893        END IF
     3894      END DO
     3895    END DO
     3896
    6863897    DO l = 1, nlay
    6873898      DO ig = 1, ngrid
    688         zla(ig, l) = (1.-fracd(ig,l))*zmax(ig)
    689         zld(ig, l) = fracd(ig, l)*zmax(ig)
    690         IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ &
    691           (1.-fracd(ig,l))
     3899        ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
     3900        masse(ig, l) = (pplev(ig, l) - pplev(ig, l + 1)) / rg
     3901      END DO
     3902    END DO
     3903
     3904    ! PRINT*,'12 OK convect8'
     3905    ! PRINT*,'WA4 ',wa_moy
     3906    ! c------------------------------------------------------------------
     3907    ! calcul du transport vertical
     3908    ! ------------------------------------------------------------------
     3909
     3910    GO TO 4444
     3911    ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
     3912    DO l = 2, nlay - 1
     3913      DO ig = 1, ngrid
     3914        IF (fm(ig, l + 1) * ptimestep>masse(ig, l) .AND. fm(ig, l + 1) * ptimestep>masse(&
     3915                ig, l + 1)) THEN
     3916          ! PRINT*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
     3917          ! s         ,fm(ig,l+1)*ptimestep
     3918          ! s         ,'   M=',masse(ig,l),masse(ig,l+1)
     3919        END IF
    6923920      END DO
    6933921    END DO
    … …  
    6953923    DO l = 1, nlay
    6963924      DO ig = 1, ngrid
    697         detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1)
    698         IF (detr(ig,l)<0.) THEN
     3925        IF (entr(ig, l) * ptimestep>masse(ig, l)) THEN
     3926          ! PRINT*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
     3927          ! s         ,entr(ig,l)*ptimestep
     3928          ! s         ,'   M=',masse(ig,l)
     3929        END IF
     3930      END DO
     3931    END DO
     3932
     3933    DO l = 1, nlay
     3934      DO ig = 1, ngrid
     3935        IF (.NOT. fm(ig, l)>=0. .OR. .NOT. fm(ig, l)<=10.) THEN
     3936          ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
     3937          ! s         ,'   FM=',fm(ig,l)
     3938        END IF
     3939        IF (.NOT. masse(ig, l)>=1.E-10 .OR. .NOT. masse(ig, l)<=1.E4) THEN
     3940          ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
     3941          ! s         ,'   M=',masse(ig,l)
     3942          ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
     3943          ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
     3944          ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
     3945          ! s                ,zlev(ig,l+1),zlev(ig,l)
     3946          ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
     3947          ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
     3948        END IF
     3949        IF (.NOT. entr(ig, l)>=0. .OR. .NOT. entr(ig, l)<=10.) THEN
     3950          ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
     3951          ! s         ,'   E=',entr(ig,l)
     3952        END IF
     3953      END DO
     3954    END DO
     3955
     3956    4444 CONTINUE
     3957
     3958    ! CR:redefinition du entr
     3959    DO l = 1, nlay
     3960      DO ig = 1, ngrid
     3961        detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l + 1)
     3962        IF (detr(ig, l)<0.) THEN
    6993963          entr(ig, l) = entr(ig, l) - detr(ig, l)
    7003964          detr(ig, l) = 0.
    … …  
    7033967      END DO
    7043968    END DO
    705   END IF
    706 
    707   ! PRINT*,'15 OK convect8'
    708 
    709 
    710   ! IF(wa_moy(1,4).gt.1.e-10) stop
    711 
    712   ! PRINT*,'19 OK convect8'
    713 
    714 END SUBROUTINE thermcell_2002
    715 
    716 SUBROUTINE thermcell_cld(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, &
    717     debut, pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0, zqla, &
    718     lmax, zmax_sec, wmax_sec, zw_sec, lmix_sec, ratqscth, ratqsdiff & ! s
    719                                                                       ! ,pu_therm,pv_therm
    720     , r_aspect, l_mix, w2di, tho)
    721 
    722   USE dimphy
    723   IMPLICIT NONE
    724 
    725   ! =======================================================================
    726 
    727   ! Calcul du transport verticale dans la couche limite en presence
    728   ! de "thermiques" explicitement representes
    729 
    730   ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
    731 
    732   ! le thermique est supposé homogène et dissipé par mélange avec
    733   ! son environnement. la longueur l_mix contrôle l'efficacité du
    734   ! mélange
    735 
    736   ! Le calcul du transport des différentes espèces se fait en prenant
    737   ! en compte:
    738   ! 1. un flux de masse montant
    739   ! 2. un flux de masse descendant
    740   ! 3. un entrainement
    741   ! 4. un detrainement
    742 
    743   ! =======================================================================
    744 
    745   ! -----------------------------------------------------------------------
    746   ! declarations:
    747   ! -------------
    748 
    749   include "YOMCST.h"
    750   include "YOETHF.h"
    751   include "FCTTRE.h"
    752 
    753   ! arguments:
    754   ! ----------
    755 
    756   INTEGER ngrid, nlay, w2di
    757   REAL tho
    758   REAL ptimestep, l_mix, r_aspect
    759   REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
    760   REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
    761   REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
    762   REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
    763   REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1)
    764   REAL pphi(ngrid, nlay)
    765 
    766   INTEGER idetr
    767   SAVE idetr
    768   DATA idetr/3/
    769   !$OMP THREADPRIVATE(idetr)
    770 
    771   ! local:
    772   ! ------
    773 
    774   INTEGER ig, k, l, lmaxa(klon), lmix(klon)
    775   REAL zsortie1d(klon)
    776   ! CR: on remplace lmax(klon,klev+1)
    777   INTEGER lmax(klon), lmin(klon), lentr(klon)
    778   REAL linter(klon)
    779   REAL zmix(klon), fracazmix(klon)
    780   REAL alpha
    781   SAVE alpha
    782   DATA alpha/1./
    783   !$OMP THREADPRIVATE(alpha)
    784 
    785   ! RC
    786   REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz
    787   REAL zmax_sec(klon)
    788   REAL zmax_sec2(klon)
    789   REAL zw_sec(klon, klev+1)
    790   INTEGER lmix_sec(klon)
    791   REAL w_est(klon, klev+1)
    792   ! on garde le zmax du pas de temps precedent
    793   ! real zmax0(klon)
    794   ! save zmax0
    795   ! real zmix0(klon)
    796   ! save zmix0
    797   REAL, SAVE, ALLOCATABLE :: zmax0(:), zmix0(:)
    798   !$OMP THREADPRIVATE(zmax0, zmix0)
    799 
    800   REAL zlev(klon, klev+1), zlay(klon, klev)
    801   REAL deltaz(klon, klev)
    802   REAL zh(klon, klev), zdhadj(klon, klev)
    803   REAL zthl(klon, klev), zdthladj(klon, klev)
    804   REAL ztv(klon, klev)
    805   REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
    806   REAL zl(klon, klev)
    807   REAL wh(klon, klev+1)
    808   REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1)
    809   REAL zla(klon, klev+1)
    810   REAL zwa(klon, klev+1)
    811   REAL zld(klon, klev+1)
    812   REAL zwd(klon, klev+1)
    813   REAL zsortie(klon, klev)
    814   REAL zva(klon, klev)
    815   REAL zua(klon, klev)
    816   REAL zoa(klon, klev)
    817 
    818   REAL zta(klon, klev)
    819   REAL zha(klon, klev)
    820   REAL wa_moy(klon, klev+1)
    821   REAL fraca(klon, klev+1)
    822   REAL fracc(klon, klev+1)
    823   REAL zf, zf2
    824   REAL thetath2(klon, klev), wth2(klon, klev), wth3(klon, klev)
    825   REAL q2(klon, klev)
    826   REAL dtheta(klon, klev)
    827   ! common/comtherm/thetath2,wth2
    828 
    829   REAL ratqscth(klon, klev)
    830   REAL sum
    831   REAL sumdiff
    832   REAL ratqsdiff(klon, klev)
    833   REAL count_time
    834   INTEGER ialt
    835 
    836   LOGICAL sorties
    837   REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev)
    838   REAL zpspsk(klon, klev)
    839 
    840   ! real wmax(klon,klev),wmaxa(klon)
    841   REAL wmax(klon), wmaxa(klon)
    842   REAL wmax_sec(klon)
    843   REAL wmax_sec2(klon)
    844   REAL wa(klon, klev, klev+1)
    845   REAL wd(klon, klev+1)
    846   REAL larg_part(klon, klev, klev+1)
    847   REAL fracd(klon, klev+1)
    848   REAL xxx(klon, klev+1)
    849   REAL larg_cons(klon, klev+1)
    850   REAL larg_detr(klon, klev+1)
    851   REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev)
    852   REAL massetot(klon, klev)
    853   REAL detr0(klon, klev)
    854   REAL alim0(klon, klev)
    855   REAL pu_therm(klon, klev), pv_therm(klon, klev)
    856   REAL fm(klon, klev+1), entr(klon, klev)
    857   REAL fmc(klon, klev+1)
    858 
    859   REAL zcor, zdelta, zcvm5, qlbef
    860   REAL tbef(klon), qsatbef(klon)
    861   REAL dqsat_dt, dt, num, denom
    862   REAL reps, rlvcp, ddt0
    863   REAL ztla(klon, klev), zqla(klon, klev), zqta(klon, klev)
    864   ! CR niveau de condensation
    865   REAL nivcon(klon)
    866   REAL zcon(klon)
    867   REAL zqsat(klon, klev)
    868   REAL zqsatth(klon, klev)
    869   PARAMETER (ddt0=.01)
    870 
    871 
    872   ! CR:nouvelles variables
    873   REAL f_star(klon, klev+1), entr_star(klon, klev)
    874   REAL detr_star(klon, klev)
    875   REAL alim_star_tot(klon), alim_star2(klon)
    876   REAL entr_star_tot(klon)
    877   REAL detr_star_tot(klon)
    878   REAL alim_star(klon, klev)
    879   REAL alim(klon, klev)
    880   REAL nu(klon, klev)
    881   REAL nu_e(klon, klev)
    882   REAL nu_min
    883   REAL nu_max
    884   REAL nu_r
    885   REAL f(klon)
    886   ! real f(klon), f0(klon)
    887   ! save f0
    888   REAL, SAVE, ALLOCATABLE :: f0(:)
    889   !$OMP THREADPRIVATE(f0)
    890 
    891   REAL f_old
    892   REAL zlevinter(klon)
    893   LOGICAL, SAVE :: first = .TRUE.
    894   !$OMP THREADPRIVATE(first)
    895   ! data first /.FALSE./
    896   ! save first
    897   LOGICAL nuage
    898   ! save nuage
    899   LOGICAL boucle
    900   LOGICAL therm
    901   LOGICAL debut
    902   LOGICAL rale
    903   INTEGER test(klon)
    904   INTEGER signe_zw2
    905   ! RC
    906 
    907   CHARACTER *2 str2
    908   CHARACTER *10 str10
    909 
    910   CHARACTER (LEN=20) :: modname = 'thermcell_cld'
    911   CHARACTER (LEN=80) :: abort_message
    912 
    913   LOGICAL vtest(klon), down
    914   LOGICAL zsat(klon)
    915 
    916   EXTERNAL scopy
    917 
    918   INTEGER ncorrec, ll
    919   SAVE ncorrec
    920   DATA ncorrec/0/
    921   !$OMP THREADPRIVATE(ncorrec)
    922 
    923 
    924 
    925   ! -----------------------------------------------------------------------
    926   ! initialisation:
    927   ! ---------------
    928 
    929   IF (first) THEN
    930     ALLOCATE (zmix0(klon))
    931     ALLOCATE (zmax0(klon))
    932     ALLOCATE (f0(klon))
    933     first = .FALSE.
    934   END IF
    935 
    936   sorties = .FALSE.
    937   ! PRINT*,'NOUVEAU DETR PLUIE '
    938   IF (ngrid/=klon) THEN
    939     PRINT *
    940     PRINT *, 'STOP dans convadj'
    941     PRINT *, 'ngrid    =', ngrid
    942     PRINT *, 'klon  =', klon
    943   END IF
    944 
    945   ! Initialisation
    946   rlvcp = rlvtt/rcpd
    947   reps = rd/rv
    948   ! initialisations de zqsat
    949   DO ll = 1, nlay
    950     DO ig = 1, ngrid
    951       zqsat(ig, ll) = 0.
    952       zqsatth(ig, ll) = 0.
    953     END DO
    954   END DO
    955 
    956   ! on met le first a true pour le premier passage de la journée
    957   DO ig = 1, klon
    958     test(ig) = 0
    959   END DO
    960   IF (debut) THEN
    961     DO ig = 1, klon
    962       test(ig) = 1
    963       f0(ig) = 0.
    964       zmax0(ig) = 0.
    965     END DO
    966   END IF
    967   DO ig = 1, klon
    968     IF ((.NOT. debut) .AND. (f0(ig)<1.E-10)) THEN
    969       test(ig) = 1
     3969    ! RC
     3970    IF (w2di==1) THEN
     3971      fm0 = fm0 + ptimestep * (fm - fm0) / tho
     3972      entr0 = entr0 + ptimestep * (entr - entr0) / tho
     3973    ELSE
     3974      fm0 = fm
     3975      entr0 = entr
    9703976    END IF
    971   END DO
    972   ! do ig=1,klon
    973   ! PRINT*,'test(ig)',test(ig),zmax0(ig)
    974   ! enddo
    975   nuage = .FALSE.
    976   ! -----------------------------------------------------------------------
    977   ! AM Calcul de T,q,ql a partir de Tl et qT
    978   ! ---------------------------------------------------
    979 
    980   ! Pr Tprec=Tl calcul de qsat
    981   ! Si qsat>qT T=Tl, q=qT
    982   ! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt)
    983   ! On cherche DDT < DDT0
    984 
    985   ! defaut
    986   DO ll = 1, nlay
    987     DO ig = 1, ngrid
    988       zo(ig, ll) = po(ig, ll)
    989       zl(ig, ll) = 0.
    990       zh(ig, ll) = pt(ig, ll)
    991     END DO
    992   END DO
    993   DO ig = 1, ngrid
    994     zsat(ig) = .FALSE.
    995   END DO
    996 
    997 
    998   DO ll = 1, nlay
    999     ! les points insatures sont definitifs
    1000     DO ig = 1, ngrid
    1001       tbef(ig) = pt(ig, ll)
    1002       zdelta = max(0., sign(1.,rtt-tbef(ig)))
    1003       qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll)
    1004       qsatbef(ig) = min(0.5, qsatbef(ig))
    1005       zcor = 1./(1.-retv*qsatbef(ig))
    1006       qsatbef(ig) = qsatbef(ig)*zcor
    1007       zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig))>1.E-10)
    1008     END DO
    1009 
    1010     DO ig = 1, ngrid
    1011       IF (zsat(ig) .AND. (1==1)) THEN
    1012         qlbef = max(0., po(ig,ll)-qsatbef(ig))
    1013         ! si sature: ql est surestime, d'ou la sous-relax
    1014         dt = 0.5*rlvcp*qlbef
    1015         ! WRITE(18,*) 'DT0=',DT
    1016         ! on pourra enchainer 2 ou 3 calculs sans Do while
    1017         DO WHILE (abs(dt)>ddt0)
    1018           ! il faut verifier si c,a conserve quand on repasse en insature ...
    1019           tbef(ig) = tbef(ig) + dt
    1020           zdelta = max(0., sign(1.,rtt-tbef(ig)))
    1021           qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll)
    1022           qsatbef(ig) = min(0.5, qsatbef(ig))
    1023           zcor = 1./(1.-retv*qsatbef(ig))
    1024           qsatbef(ig) = qsatbef(ig)*zcor
    1025           ! on veut le signe de qlbef
    1026           qlbef = po(ig, ll) - qsatbef(ig)
    1027           zdelta = max(0., sign(1.,rtt-tbef(ig)))
    1028           zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta
    1029           zcor = 1./(1.-retv*qsatbef(ig))
    1030           dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor)
    1031           num = -tbef(ig) + pt(ig, ll) + rlvcp*qlbef
    1032           denom = 1. + rlvcp*dqsat_dt
    1033           IF (denom<1.E-10) THEN
    1034             PRINT *, 'pb denom'
    1035           END IF
    1036           dt = num/denom
    1037         END DO
    1038         ! on ecrit de maniere conservative (sat ou non)
    1039         zl(ig, ll) = max(0., qlbef)
    1040         ! T = Tl +Lv/Cp ql
    1041         zh(ig, ll) = pt(ig, ll) + rlvcp*zl(ig, ll)
    1042         zo(ig, ll) = po(ig, ll) - zl(ig, ll)
    1043       END IF
    1044       ! on ecrit zqsat
    1045       zqsat(ig, ll) = qsatbef(ig)
    1046     END DO
    1047   END DO
    1048   ! AM fin
    1049 
    1050   ! -----------------------------------------------------------------------
    1051   ! incrementation eventuelle de tendances precedentes:
    1052   ! ---------------------------------------------------
    1053 
    1054   ! PRINT*,'0 OK convect8'
    1055 
    1056   DO l = 1, nlay
    1057     DO ig = 1, ngrid
    1058       zpspsk(ig, l) = (pplay(ig,l)/100000.)**rkappa
    1059       ! zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
    1060       ! zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
    1061       zu(ig, l) = pu(ig, l)
    1062       zv(ig, l) = pv(ig, l)
    1063       ! zo(ig,l)=po(ig,l)
    1064       ! ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
    1065       ! AM attention zh est maintenant le profil de T et plus le profil de
    1066       ! theta !
    1067 
    1068       ! T-> Theta
    1069       ztv(ig, l) = zh(ig, l)/zpspsk(ig, l)
    1070       ! AM Theta_v
    1071       ztv(ig, l) = ztv(ig, l)*(1.+retv*(zo(ig,l))-zl(ig,l))
    1072       ! AM Thetal
    1073       zthl(ig, l) = pt(ig, l)/zpspsk(ig, l)
    1074 
    1075     END DO
    1076   END DO
    1077 
    1078   ! PRINT*,'1 OK convect8'
    1079   ! --------------------
    1080 
    1081 
    1082   ! + + + + + + + + + + +
    1083 
    1084 
    1085   ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
    1086   ! wh,wt,wo ...
    1087 
    1088   ! + + + + + + + + + + +  zh,zu,zv,zo,rho
    1089 
    1090 
    1091   ! --------------------   zlev(1)
    1092   ! \\\\\\\\\\\\\\\\\\\\
    1093 
    1094 
    1095 
    1096   ! -----------------------------------------------------------------------
    1097   ! Calcul des altitudes des couches
    1098   ! -----------------------------------------------------------------------
    1099 
    1100   DO l = 2, nlay
    1101     DO ig = 1, ngrid
    1102       zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg
    1103     END DO
    1104   END DO
    1105   DO ig = 1, ngrid
    1106     zlev(ig, 1) = 0.
    1107     zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg
    1108   END DO
    1109   DO l = 1, nlay
    1110     DO ig = 1, ngrid
    1111       zlay(ig, l) = pphi(ig, l)/rg
    1112     END DO
    1113   END DO
    1114   ! calcul de deltaz
    1115   DO l = 1, nlay
    1116     DO ig = 1, ngrid
    1117       deltaz(ig, l) = zlev(ig, l+1) - zlev(ig, l)
    1118     END DO
    1119   END DO
    1120 
    1121   ! PRINT*,'2 OK convect8'
    1122   ! -----------------------------------------------------------------------
    1123   ! Calcul des densites
    1124   ! -----------------------------------------------------------------------
    1125 
    1126   DO l = 1, nlay
    1127     DO ig = 1, ngrid
    1128       ! rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
    1129       rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*ztv(ig,l))
    1130     END DO
    1131   END DO
    1132 
    1133   DO l = 2, nlay
    1134     DO ig = 1, ngrid
    1135       rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1))
    1136     END DO
    1137   END DO
    1138 
    1139   DO k = 1, nlay
    1140     DO l = 1, nlay + 1
    1141       DO ig = 1, ngrid
    1142         wa(ig, k, l) = 0.
    1143       END DO
    1144     END DO
    1145   END DO
    1146   ! Cr:ajout:calcul de la masse
    1147   DO l = 1, nlay
    1148     DO ig = 1, ngrid
    1149       ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    1150       masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg
    1151     END DO
    1152   END DO
    1153   ! PRINT*,'3 OK convect8'
    1154   ! ------------------------------------------------------------------
    1155   ! Calcul de w2, quarre de w a partir de la cape
    1156   ! a partir de w2, on calcule wa, vitesse de l'ascendance
    1157 
    1158   ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
    1159   ! w2 est stoke dans wa
    1160 
    1161   ! ATTENTION: dans convect8, on n'utilise le calcule des wa
    1162   ! independants par couches que pour calculer l'entrainement
    1163   ! a la base et la hauteur max de l'ascendance.
    1164 
    1165   ! Indicages:
    1166   ! l'ascendance provenant du niveau k traverse l'interface l avec
    1167   ! une vitesse wa(k,l).
    1168 
    1169   ! --------------------
    1170 
    1171   ! + + + + + + + + + +
    1172 
    1173   ! wa(k,l)   ----       --------------------    l
    1174   ! /\
    1175   ! /||\       + + + + + + + + + +
    1176   ! ||
    1177   ! ||        --------------------
    1178   ! ||
    1179   ! ||        + + + + + + + + + +
    1180   ! ||
    1181   ! ||        --------------------
    1182   ! ||__
    1183   ! |___      + + + + + + + + + +     k
    1184 
    1185   ! --------------------
    1186 
    1187 
    1188 
    1189   ! ------------------------------------------------------------------
    1190 
    1191   ! CR: ponderation entrainement des couches instables
    1192   ! def des alim_star tels que alim=f*alim_star
    1193   DO l = 1, klev
    1194     DO ig = 1, ngrid
    1195       alim_star(ig, l) = 0.
    1196       alim(ig, l) = 0.
    1197     END DO
    1198   END DO
    1199   ! determination de la longueur de la couche d entrainement
    1200   DO ig = 1, ngrid
    1201     lentr(ig) = 1
    1202   END DO
    1203 
    1204   ! on ne considere que les premieres couches instables
    1205   therm = .FALSE.
    1206   DO k = nlay - 2, 1, -1
    1207     DO ig = 1, ngrid
    1208       IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN
    1209         lentr(ig) = k + 1
    1210         therm = .TRUE.
    1211       END IF
    1212     END DO
    1213   END DO
    1214 
    1215   ! determination du lmin: couche d ou provient le thermique
    1216   DO ig = 1, ngrid
    1217     lmin(ig) = 1
    1218   END DO
    1219   DO ig = 1, ngrid
    1220     DO l = nlay, 2, -1
    1221       IF (ztv(ig,l-1)>ztv(ig,l)) THEN
    1222         lmin(ig) = l - 1
    1223       END IF
    1224     END DO
    1225   END DO
    1226 
    1227   ! definition de l'entrainement des couches
    1228   DO l = 1, klev - 1
    1229     DO ig = 1, ngrid
    1230       IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<lentr(ig)) THEN
    1231         ! def possibles pour alim_star: zdthetadz, dthetadz, zdtheta
    1232         alim_star(ig, l) = max((ztv(ig,l)-ztv(ig,l+1)), 0.) & ! s
    1233                                                               ! *(zlev(ig,l+1)-zlev(ig,l))
    1234           *sqrt(zlev(ig,l+1))
    1235         ! alim_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
    1236         ! s                         /zlev(ig,lentr(ig)+2)))**(3./2.)
    1237       END IF
    1238     END DO
    1239   END DO
    1240 
    1241   ! pas de thermique si couche 1 stable
    1242   DO ig = 1, ngrid
    1243     ! if (lmin(ig).gt.1) THEN
    1244     ! CRnouveau test
    1245     IF (alim_star(ig,1)<1.E-10) THEN
    1246       DO l = 1, klev
    1247         alim_star(ig, l) = 0.
    1248       END DO
     3977
     3978    IF (1==1) THEN
     3979      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, &
     3980              zha)
     3981      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, &
     3982              zoa)
     3983    ELSE
     3984      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
     3985              zdhadj, zha)
     3986      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
     3987              pdoadj, zoa)
    12493988    END IF
    1250   END DO
    1251   ! calcul de l entrainement total
    1252   DO ig = 1, ngrid
    1253     alim_star_tot(ig) = 0.
    1254     entr_star_tot(ig) = 0.
    1255     detr_star_tot(ig) = 0.
    1256   END DO
    1257   DO ig = 1, ngrid
    1258     DO k = 1, klev
    1259       alim_star_tot(ig) = alim_star_tot(ig) + alim_star(ig, k)
    1260     END DO
    1261   END DO
    1262 
    1263   ! Calcul entrainement normalise
    1264   DO ig = 1, ngrid
    1265     IF (alim_star_tot(ig)>1.E-10) THEN
    1266       ! do l=1,lentr(ig)
    1267       DO l = 1, klev
    1268         ! def possibles pour entr_star: zdthetadz, dthetadz, zdtheta
    1269         alim_star(ig, l) = alim_star(ig, l)/alim_star_tot(ig)
    1270       END DO
     3989
     3990    IF (1==0) THEN
     3991      CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
     3992              zu, zv, pduadj, pdvadj, zua, zva)
     3993    ELSE
     3994      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
     3995              zua)
     3996      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
     3997              zva)
    12713998    END IF
    1272   END DO
    1273 
    1274   ! PRINT*,'fin calcul alim_star'
    1275 
    1276   ! AM:initialisations
    1277   DO k = 1, nlay
    1278     DO ig = 1, ngrid
    1279       ztva(ig, k) = ztv(ig, k)
    1280       ztla(ig, k) = zthl(ig, k)
    1281       zqla(ig, k) = 0.
    1282       zqta(ig, k) = po(ig, k)
    1283       zsat(ig) = .FALSE.
    1284     END DO
    1285   END DO
    1286   DO k = 1, klev
    1287     DO ig = 1, ngrid
    1288       detr_star(ig, k) = 0.
    1289       entr_star(ig, k) = 0.
    1290       detr(ig, k) = 0.
    1291       entr(ig, k) = 0.
    1292     END DO
    1293   END DO
    1294   ! PRINT*,'7 OK convect8'
    1295   DO k = 1, klev + 1
    1296     DO ig = 1, ngrid
    1297       zw2(ig, k) = 0.
    1298       fmc(ig, k) = 0.
    1299       ! CR
    1300       f_star(ig, k) = 0.
    1301       ! RC
    1302       larg_cons(ig, k) = 0.
    1303       larg_detr(ig, k) = 0.
    1304       wa_moy(ig, k) = 0.
    1305     END DO
    1306   END DO
    1307 
    1308   ! n     PRINT*,'8 OK convect8'
    1309   DO ig = 1, ngrid
    1310     linter(ig) = 1.
    1311     lmaxa(ig) = 1
    1312     lmix(ig) = 1
    1313     wmaxa(ig) = 0.
    1314   END DO
    1315 
    1316   nu_min = l_mix
    1317   nu_max = 1000.
    1318   ! do ig=1,ngrid
    1319   ! nu_max=wmax_sec(ig)
    1320   ! enddo
    1321   DO ig = 1, ngrid
    1322     DO k = 1, klev
    1323       nu(ig, k) = 0.
    1324       nu_e(ig, k) = 0.
    1325     END DO
    1326   END DO
    1327   ! Calcul de l'excès de température du à la diffusion turbulente
    1328   DO ig = 1, ngrid
    1329     DO l = 1, klev
    1330       dtheta(ig, l) = 0.
    1331     END DO
    1332   END DO
    1333   DO ig = 1, ngrid
    1334     DO l = 1, lentr(ig) - 1
    1335       dtheta(ig, l) = sqrt(10.*0.4*zlev(ig,l+1)**2*1.*((ztv(ig,l+1)- &
    1336         ztv(ig,l))/(zlev(ig,l+1)-zlev(ig,l)))**2)
    1337     END DO
    1338   END DO
    1339   ! do l=1,nlay-2
    1340   DO l = 1, klev - 1
    1341     DO ig = 1, ngrid
    1342       IF (ztv(ig,l)>ztv(ig,l+1) .AND. alim_star(ig,l)>1.E-10 .AND. &
    1343           zw2(ig,l)<1E-10) THEN
    1344         ! AM
    1345         ! test:on rajoute un excès de T dans couche alim
    1346         ! ztla(ig,l)=zthl(ig,l)+dtheta(ig,l)
    1347         ztla(ig, l) = zthl(ig, l)
    1348         ! test: on rajoute un excès de q dans la couche alim
    1349         ! zqta(ig,l)=po(ig,l)+0.001
    1350         zqta(ig, l) = po(ig, l)
    1351         zqla(ig, l) = zl(ig, l)
    1352         ! AM
    1353         f_star(ig, l+1) = alim_star(ig, l)
    1354         ! test:calcul de dteta
    1355         zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* &
    1356           (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l))
    1357         w_est(ig, l+1) = zw2(ig, l+1)
    1358         larg_detr(ig, l) = 0.
    1359         ! PRINT*,'coucou boucle 1'
    1360       ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+alim_star(ig, &
    1361           l))>1.E-10) THEN
    1362         ! PRINT*,'coucou boucle 2'
    1363         ! estimation du detrainement a partir de la geometrie du pas
    1364         ! precedent
    1365         IF ((test(ig)==1) .OR. ((.NOT. debut) .AND. (f0(ig)<1.E-10))) THEN
    1366           detr_star(ig, l) = 0.
    1367           entr_star(ig, l) = 0.
    1368           ! PRINT*,'coucou test(ig)',test(ig),f0(ig),zmax0(ig)
    1369         ELSE
    1370           ! PRINT*,'coucou debut detr'
    1371           ! tests sur la definition du detr
    1372           IF (zqla(ig,l-1)>1.E-10) THEN
    1373             nuage = .TRUE.
    1374           END IF
    1375 
    1376           w_est(ig, l+1) = zw2(ig, l)*((f_star(ig,l))**2)/(f_star(ig,l)+ &
    1377             alim_star(ig,l))**2 + 2.*rg*(ztva(ig,l-1)-ztv(ig,l))/ztv(ig, l)*( &
    1378             zlev(ig,l+1)-zlev(ig,l))
    1379           IF (w_est(ig,l+1)<0.) THEN
    1380             w_est(ig, l+1) = zw2(ig, l)
    1381           END IF
    1382           IF (l>2) THEN
    1383             IF ((w_est(ig,l+1)>w_est(ig,l)) .AND. (zlev(ig, &
    1384                 l+1)<zmax_sec(ig)) .AND. (zqla(ig,l-1)<1.E-10)) THEN
    1385               detr_star(ig, l) = max(0., (rhobarz(ig, &
    1386                 l+1)*sqrt(w_est(ig,l+1))*sqrt(nu(ig,l)* &
    1387                 zlev(ig,l+1))-rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(nu(ig,l)* &
    1388                 zlev(ig,l)))/(r_aspect*zmax_sec(ig)))
    1389             ELSE IF ((zlev(ig,l+1)<zmax_sec(ig)) .AND. (zqla(ig, &
    1390                 l-1)<1.E-10)) THEN
    1391               detr_star(ig, l) = -f0(ig)*f_star(ig, lmix(ig))/(rhobarz(ig, &
    1392                 lmix(ig))*wmaxa(ig))*(rhobarz(ig,l+1)*sqrt(w_est(ig, &
    1393                 l+1))*((zmax_sec(ig)-zlev(ig,l+1))/((zmax_sec(ig)-zlev(ig, &
    1394                 lmix(ig)))))**2.-rhobarz(ig,l)*sqrt(w_est(ig, &
    1395                 l))*((zmax_sec(ig)-zlev(ig,l))/((zmax_sec(ig)-zlev(ig,lmix(ig &
    1396                 )))))**2.)
    1397             ELSE
    1398               detr_star(ig, l) = 0.002*f0(ig)*f_star(ig, l)* &
    1399                 (zlev(ig,l+1)-zlev(ig,l))
    1400 
    1401             END IF
    1402           ELSE
    1403             detr_star(ig, l) = 0.
    1404           END IF
    1405 
    1406           detr_star(ig, l) = detr_star(ig, l)/f0(ig)
    1407           IF (nuage) THEN
    1408             entr_star(ig, l) = 0.4*detr_star(ig, l)
    1409           ELSE
    1410             entr_star(ig, l) = 0.4*detr_star(ig, l)
    1411           END IF
    1412 
    1413           IF ((detr_star(ig,l))>f_star(ig,l)) THEN
    1414             detr_star(ig, l) = f_star(ig, l)
    1415             ! entr_star(ig,l)=0.
    1416           END IF
    1417 
    1418           IF ((l<lentr(ig))) THEN
    1419             entr_star(ig, l) = 0.
    1420             ! detr_star(ig,l)=0.
    1421           END IF
    1422 
    1423           ! PRINT*,'ok detr_star'
    1424         END IF
    1425         ! prise en compte du detrainement dans le calcul du flux
    1426         f_star(ig, l+1) = f_star(ig, l) + alim_star(ig, l) + &
    1427           entr_star(ig, l) - detr_star(ig, l)
    1428         ! test
    1429         ! if (f_star(ig,l+1).lt.0.) THEN
    1430         ! f_star(ig,l+1)=0.
    1431         ! entr_star(ig,l)=0.
    1432         ! detr_star(ig,l)=f_star(ig,l)+alim_star(ig,l)
    1433         ! END IF
    1434         ! test sur le signe de f_star
    1435         IF (f_star(ig,l+1)>1.E-10) THEN
    1436           ! THEN
    1437           ! test
    1438           ! if (((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10)) THEN
    1439           ! AM on melange Tl et qt du thermique
    1440           ! on rajoute un excès de T dans la couche alim
    1441           ! if (l.lt.lentr(ig)) THEN
    1442           ! ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+
    1443           ! s
    1444           ! (alim_star(ig,l)+entr_star(ig,l))*(zthl(ig,l)+dtheta(ig,l)))
    1445           ! s     /(f_star(ig,l+1)+detr_star(ig,l))
    1446           ! else
    1447           ztla(ig, l) = (f_star(ig,l)*ztla(ig,l-1)+(alim_star(ig, &
    1448             l)+entr_star(ig,l))*zthl(ig,l))/(f_star(ig,l+1)+detr_star(ig,l))
    1449           ! s                    /(f_star(ig,l+1))
    1450           ! END IF
    1451           ! on rajoute un excès de q dans la couche alim
    1452           ! if (l.lt.lentr(ig)) THEN
    1453           ! zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+
    1454           ! s           (alim_star(ig,l)+entr_star(ig,l))*(po(ig,l)+0.001))
    1455           ! s                 /(f_star(ig,l+1)+detr_star(ig,l))
    1456           ! else
    1457           zqta(ig, l) = (f_star(ig,l)*zqta(ig,l-1)+(alim_star(ig, &
    1458             l)+entr_star(ig,l))*po(ig,l))/(f_star(ig,l+1)+detr_star(ig,l))
    1459           ! s                   /(f_star(ig,l+1))
    1460           ! END IF
    1461           ! AM on en deduit thetav et ql du thermique
    1462           ! CR test
    1463           ! Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
    1464           tbef(ig) = ztla(ig, l)*zpspsk(ig, l)
    1465           zdelta = max(0., sign(1.,rtt-tbef(ig)))
    1466           qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l)
    1467           qsatbef(ig) = min(0.5, qsatbef(ig))
    1468           zcor = 1./(1.-retv*qsatbef(ig))
    1469           qsatbef(ig) = qsatbef(ig)*zcor
    1470           zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig))>1.E-10)
    1471 
    1472           IF (zsat(ig) .AND. (1==1)) THEN
    1473             qlbef = max(0., zqta(ig,l)-qsatbef(ig))
    1474             dt = 0.5*rlvcp*qlbef
    1475             ! WRITE(17,*)'DT0=',DT
    1476             DO WHILE (abs(dt)>ddt0)
    1477               ! PRINT*,'aie'
    1478               tbef(ig) = tbef(ig) + dt
    1479               zdelta = max(0., sign(1.,rtt-tbef(ig)))
    1480               qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l)
    1481               qsatbef(ig) = min(0.5, qsatbef(ig))
    1482               zcor = 1./(1.-retv*qsatbef(ig))
    1483               qsatbef(ig) = qsatbef(ig)*zcor
    1484               qlbef = zqta(ig, l) - qsatbef(ig)
    1485 
    1486               zdelta = max(0., sign(1.,rtt-tbef(ig)))
    1487               zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta
    1488               zcor = 1./(1.-retv*qsatbef(ig))
    1489               dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor)
    1490               num = -tbef(ig) + ztla(ig, l)*zpspsk(ig, l) + rlvcp*qlbef
    1491               denom = 1. + rlvcp*dqsat_dt
    1492               IF (denom<1.E-10) THEN
    1493                 PRINT *, 'pb denom'
    1494               END IF
    1495               dt = num/denom
    1496               ! WRITE(17,*)'DT=',DT
    1497             END DO
    1498             zqla(ig, l) = max(0., zqta(ig,l)-qsatbef(ig))
    1499             zqla(ig, l) = max(0., qlbef)
    1500             ! zqla(ig,l)=0.
    1501           END IF
    1502           ! zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
    1503 
    1504           ! on ecrit de maniere conservative (sat ou non)
    1505           ! T = Tl +Lv/Cp ql
    1506           ! CR rq utilisation de humidite specifique ou rapport de melange?
    1507           ztva(ig, l) = ztla(ig, l)*zpspsk(ig, l) + rlvcp*zqla(ig, l)
    1508           ztva(ig, l) = ztva(ig, l)/zpspsk(ig, l)
    1509           ! on rajoute le calcul de zha pour diagnostiques (temp potentielle)
    1510           zha(ig, l) = ztva(ig, l)
    1511           ! if (l.lt.lentr(ig)) THEN
    1512           ! ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
    1513           ! s              -zqla(ig,l))-zqla(ig,l)) + 0.1
    1514           ! else
    1515           ztva(ig, l) = ztva(ig, l)*(1.+retv*(zqta(ig,l)-zqla(ig, &
    1516             l))-zqla(ig,l))
    1517           ! END IF
    1518           ! ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
    1519           ! s                 /(1.-retv*zqla(ig,l))
    1520           ! ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
    1521           ! ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
    1522           ! s                 /(1.-retv*zqta(ig,l))
    1523           ! s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
    1524           ! s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
    1525           ! WRITE(13,*)zqla(ig,l),zqla(ig,l)/(1.-retv*zqla(ig,l))
    1526           ! on ecrit zqsat
    1527           zqsatth(ig, l) = qsatbef(ig)
    1528           ! enddo
    1529           ! DO ig=1,ngrid
    1530           ! if (zw2(ig,l).ge.1.e-10.AND.
    1531           ! s               f_star(ig,l)+entr_star(ig,l).gt.1.e-10) THEN
    1532           ! mise a jour de la vitesse ascendante (l'air entraine de la couche
    1533           ! consideree commence avec une vitesse nulle).
    1534 
    1535           ! if (f_star(ig,l+1).gt.1.e-10) THEN
    1536           zw2(ig, l+1) = zw2(ig, l)* & ! s
    1537                                        ! ((f_star(ig,l)-detr_star(ig,l))**2)
    1538           ! s                  /f_star(ig,l+1)**2+
    1539             ((f_star(ig,l))**2)/(f_star(ig,l+1)+detr_star(ig,l))**2 + & ! s
    1540                                                                         ! /(f_star(ig,l+1))**2+
    1541             2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l))
    1542           ! s                   *(f_star(ig,l)/f_star(ig,l+1))**2
    1543 
    1544         END IF
    1545       END IF
    1546 
    1547       IF (zw2(ig,l+1)<0.) THEN
    1548         linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( &
    1549           ig,l))
    1550         zw2(ig, l+1) = 0.
    1551         ! PRINT*,'linter=',linter(ig)
    1552         ! ELSE IF ((zw2(ig,l+1).lt.1.e-10).AND.(zw2(ig,l+1).ge.0.)) THEN
    1553         ! linter(ig)=l+1
    1554         ! PRINT*,'linter=l',zw2(ig,l),zw2(ig,l+1)
    1555       ELSE
    1556         wa_moy(ig, l+1) = sqrt(zw2(ig,l+1))
    1557         ! wa_moy(ig,l+1)=zw2(ig,l+1)
    1558       END IF
    1559       IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN
    1560         ! lmix est le niveau de la couche ou w (wa_moy) est maximum
    1561         lmix(ig) = l + 1
    1562         wmaxa(ig) = wa_moy(ig, l+1)
    1563       END IF
    1564     END DO
    1565   END DO
    1566   PRINT *, 'fin calcul zw2'
    1567 
    1568   ! Calcul de la couche correspondant a la hauteur du thermique
    1569   DO ig = 1, ngrid
    1570     lmax(ig) = lentr(ig)
    1571   END DO
    1572   DO ig = 1, ngrid
    1573     DO l = nlay, lentr(ig) + 1, -1
    1574       IF (zw2(ig,l)<=1.E-10) THEN
    1575         lmax(ig) = l - 1
    1576       END IF
    1577     END DO
    1578   END DO
    1579   ! pas de thermique si couche 1 stable
    1580   DO ig = 1, ngrid
    1581     IF (lmin(ig)>1) THEN
    1582       lmax(ig) = 1
    1583       lmin(ig) = 1
    1584       lentr(ig) = 1
    1585     END IF
    1586   END DO
    1587 
    1588   ! Determination de zw2 max
    1589   DO ig = 1, ngrid
    1590     wmax(ig) = 0.
    1591   END DO
    1592 
    1593   DO l = 1, nlay
    1594     DO ig = 1, ngrid
    1595       IF (l<=lmax(ig)) THEN
    1596         IF (zw2(ig,l)<0.) THEN
    1597           PRINT *, 'pb2 zw2<0'
    1598         END IF
    1599         zw2(ig, l) = sqrt(zw2(ig,l))
    1600         wmax(ig) = max(wmax(ig), zw2(ig,l))
    1601       ELSE
    1602         zw2(ig, l) = 0.
    1603       END IF
    1604     END DO
    1605   END DO
    1606 
    1607   ! Longueur caracteristique correspondant a la hauteur des thermiques.
    1608   DO ig = 1, ngrid
    1609     zmax(ig) = 0.
    1610     zlevinter(ig) = zlev(ig, 1)
    1611   END DO
    1612   DO ig = 1, ngrid
    1613     ! calcul de zlevinter
    1614     zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + &
    1615       zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
    1616     ! pour le cas ou on prend tjs lmin=1
    1617     ! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
    1618     zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,1))
    1619     zmax0(ig) = zmax(ig)
    1620     WRITE (11, *) 'ig,lmax,linter', ig, lmax(ig), linter(ig)
    1621     WRITE (12, *) 'ig,zlevinter,zmax', ig, zmax(ig), zlevinter(ig)
    1622   END DO
    1623 
    1624   ! Calcul de zmax_sec et wmax_sec
    1625   CALL fermeture_seche(ngrid, nlay, pplay, pplev, pphi, zlev, rhobarz, f0, &
    1626     zpspsk, alim, zh, zo, lentr, lmin, nu_min, nu_max, r_aspect, zmax_sec2, &
    1627     wmax_sec2)
    1628 
    1629   PRINT *, 'avant fermeture'
    1630   ! Fermeture,determination de f
    1631   ! en lmax f=d-e
    1632   DO ig = 1, ngrid
    1633     ! entr_star(ig,lmax(ig))=0.
    1634     ! f_star(ig,lmax(ig)+1)=0.
    1635     ! detr_star(ig,lmax(ig))=f_star(ig,lmax(ig))+entr_star(ig,lmax(ig))
    1636     ! s                       +alim_star(ig,lmax(ig))
    1637   END DO
    1638 
    1639   DO ig = 1, ngrid
    1640     alim_star2(ig) = 0.
    1641   END DO
    1642   ! calcul de entr_star_tot
    1643   DO ig = 1, ngrid
    1644     DO k = 1, lmix(ig)
    1645       entr_star_tot(ig) = entr_star_tot(ig) & ! s
    1646                                               ! +entr_star(ig,k)
    1647         +alim_star(ig, k)
    1648       ! s                        -detr_star(ig,k)
    1649       detr_star_tot(ig) = detr_star_tot(ig) & ! s
    1650                                               ! +alim_star(ig,k)
    1651         -detr_star(ig, k) + entr_star(ig, k)
    1652     END DO
    1653   END DO
    1654 
    1655   DO ig = 1, ngrid
    1656     IF (alim_star_tot(ig)<1.E-10) THEN
    1657       f(ig) = 0.
    1658     ELSE
    1659       ! do k=lmin(ig),lentr(ig)
    1660       DO k = 1, lentr(ig)
    1661         alim_star2(ig) = alim_star2(ig) + alim_star(ig, k)**2/(rho(ig,k)*( &
    1662           zlev(ig,k+1)-zlev(ig,k)))
    1663       END DO
    1664       IF ((zmax_sec(ig)>1.E-10) .AND. (1==1)) THEN
    1665         f(ig) = wmax_sec(ig)/(max(500.,zmax_sec(ig))*r_aspect*alim_star2(ig))
    1666         f(ig) = f(ig) + (f0(ig)-f(ig))*exp((-ptimestep/zmax_sec(ig))*wmax_sec &
    1667           (ig))
    1668       ELSE
    1669         f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*alim_star2(ig))
    1670         f(ig) = f(ig) + (f0(ig)-f(ig))*exp((-ptimestep/zmax(ig))*wmax(ig))
    1671       END IF
    1672     END IF
    1673     f0(ig) = f(ig)
    1674   END DO
    1675   PRINT *, 'apres fermeture'
    1676   ! Calcul de l'entrainement
    1677   DO ig = 1, ngrid
    1678     DO k = 1, klev
    1679       alim(ig, k) = f(ig)*alim_star(ig, k)
    1680     END DO
    1681   END DO
    1682   ! CR:test pour entrainer moins que la masse
    1683   ! do ig=1,ngrid
    1684   ! do l=1,lentr(ig)
    1685   ! if ((alim(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) THEN
    1686   ! alim(ig,l+1)=alim(ig,l+1)+alim(ig,l)
    1687   ! s                       -0.9*masse(ig,l)/ptimestep
    1688   ! alim(ig,l)=0.9*masse(ig,l)/ptimestep
    1689   ! END IF
    1690   ! enddo
    1691   ! enddo
    1692   ! calcul du détrainement
    1693   DO ig = 1, klon
    1694     DO k = 1, klev
    1695       detr(ig, k) = f(ig)*detr_star(ig, k)
    1696       IF (detr(ig,k)<0.) THEN
    1697         ! PRINT*,'detr1<0!!!'
    1698       END IF
    1699     END DO
    1700     DO k = 1, klev
    1701       entr(ig, k) = f(ig)*entr_star(ig, k)
    1702       IF (entr(ig,k)<0.) THEN
    1703         ! PRINT*,'entr1<0!!!'
    1704       END IF
    1705     END DO
    1706   END DO
    1707 
    1708   ! do ig=1,ngrid
    1709   ! do l=1,klev
    1710   ! if (((detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep).gt.
    1711   ! s          (masse(ig,l))) THEN
    1712   ! PRINT*,'d2+e2+a2>m2','ig=',ig,'l=',l,'lmax(ig)=',lmax(ig),'d+e+a='
    1713   ! s,(detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep,'m=',masse(ig,l)
    1714   ! END IF
    1715   ! enddo
    1716   ! enddo
    1717   ! Calcul des flux
    1718 
    1719   DO ig = 1, ngrid
    1720     DO l = 1, lmax(ig)
    1721       ! do l=1,klev
    1722       ! fmc(ig,l+1)=f(ig)*f_star(ig,l+1)
    1723       fmc(ig, l+1) = fmc(ig, l) + alim(ig, l) + entr(ig, l) - detr(ig, l)
    1724       ! PRINT*,'??!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
    1725       ! s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
    1726       ! s  'f+1=',fmc(ig,l+1)
    1727       IF (fmc(ig,l+1)<0.) THEN
    1728         PRINT *, 'fmc1<0', l + 1, lmax(ig), fmc(ig, l+1)
    1729         fmc(ig, l+1) = fmc(ig, l)
    1730         detr(ig, l) = alim(ig, l) + entr(ig, l)
    1731         ! fmc(ig,l+1)=0.
    1732         ! PRINT*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1)
    1733       END IF
    1734       ! if ((fmc(ig,l+1).gt.fmc(ig,l)).AND.(l.gt.lentr(ig))) THEN
    1735       ! f_old=fmc(ig,l+1)
    1736       ! fmc(ig,l+1)=fmc(ig,l)
    1737       ! detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
    1738       ! END IF
    1739 
    1740       ! if ((fmc(ig,l+1).gt.fmc(ig,l)).AND.(l.gt.lentr(ig))) THEN
    1741       ! f_old=fmc(ig,l+1)
    1742       ! fmc(ig,l+1)=fmc(ig,l)
    1743       ! detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l)
    1744       ! END IF
    1745       ! rajout du test sur alpha croissant
    1746       ! if test
    1747       ! if (1.EQ.0) THEN
    1748       IF (l==klev) THEN
    1749         PRINT *, 'THERMCELL PB ig=', ig, '   l=', l
    1750         abort_message = 'THERMCELL PB'
    1751         CALL abort_physic(modname, abort_message, 1)
    1752       END IF
    1753       ! if ((zw2(ig,l+1).gt.1.e-10).AND.(zw2(ig,l).gt.1.e-10).AND.
    1754       ! s     (l.ge.lentr(ig)).AND.
    1755       IF ((zw2(ig,l+1)>1.E-10) .AND. (zw2(ig,l)>1.E-10) .AND. (l>=lentr(ig))) &
    1756           THEN
    1757         IF (((fmc(ig,l+1)/(rhobarz(ig,l+1)*zw2(ig,l+1)))>(fmc(ig,l)/ &
    1758             (rhobarz(ig,l)*zw2(ig,l))))) THEN
    1759           f_old = fmc(ig, l+1)
    1760           fmc(ig, l+1) = fmc(ig, l)*rhobarz(ig, l+1)*zw2(ig, l+1)/ &
    1761             (rhobarz(ig,l)*zw2(ig,l))
    1762           detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l+1)
    1763           ! detr(ig,l)=(fmc(ig,l+1)-fmc(ig,l))/(0.4-1.)
    1764           ! entr(ig,l)=0.4*detr(ig,l)
    1765           ! entr(ig,l)=fmc(ig,l+1)-fmc(ig,l)+detr(ig,l)
    1766         END IF
    1767       END IF
    1768       IF ((fmc(ig,l+1)>fmc(ig,l)) .AND. (l>lentr(ig))) THEN
    1769         f_old = fmc(ig, l+1)
    1770         fmc(ig, l+1) = fmc(ig, l)
    1771         detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l+1)
    1772       END IF
    1773       IF (detr(ig,l)>fmc(ig,l)) THEN
    1774         detr(ig, l) = fmc(ig, l)
    1775         entr(ig, l) = fmc(ig, l+1) - alim(ig, l)
    1776       END IF
    1777       IF (fmc(ig,l+1)<0.) THEN
    1778         detr(ig, l) = detr(ig, l) + fmc(ig, l+1)
    1779         fmc(ig, l+1) = 0.
    1780         PRINT *, 'fmc2<0', l + 1, lmax(ig)
    1781       END IF
    1782 
    1783       ! test pour ne pas avoir f=0 et d=e/=0
    1784       ! if (fmc(ig,l+1).lt.1.e-10) THEN
    1785       ! detr(ig,l+1)=0.
    1786       ! entr(ig,l+1)=0.
    1787       ! zqla(ig,l+1)=0.
    1788       ! zw2(ig,l+1)=0.
    1789       ! lmax(ig)=l+1
    1790       ! zmax(ig)=zlev(ig,lmax(ig))
    1791       ! END IF
    1792       IF (zw2(ig,l+1)>1.E-10) THEN
    1793         IF ((((fmc(ig,l+1))/(rhobarz(ig,l+1)*zw2(ig,l+1)))>1.)) THEN
    1794           f_old = fmc(ig, l+1)
    1795           fmc(ig, l+1) = rhobarz(ig, l+1)*zw2(ig, l+1)
    1796           zw2(ig, l+1) = 0.
    1797           zqla(ig, l+1) = 0.
    1798           detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l+1)
    1799           lmax(ig) = l + 1
    1800           zmax(ig) = zlev(ig, lmax(ig))
    1801           PRINT *, 'alpha>1', l + 1, lmax(ig)
    1802         END IF
    1803       END IF
    1804       ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
    1805       ! END IF test
    1806       ! END IF
    1807     END DO
    1808   END DO
    1809   DO ig = 1, ngrid
    1810     ! if (fmc(ig,lmax(ig)+1).NE.0.) THEN
    1811     fmc(ig, lmax(ig)+1) = 0.
    1812     entr(ig, lmax(ig)) = 0.
    1813     detr(ig, lmax(ig)) = fmc(ig, lmax(ig)) + entr(ig, lmax(ig)) + &
    1814       alim(ig, lmax(ig))
    1815     ! END IF
    1816   END DO
    1817   ! test sur le signe de fmc
    1818   DO ig = 1, ngrid
    1819     DO l = 1, klev + 1
    1820       IF (fmc(ig,l)<0.) THEN
    1821         PRINT *, 'fm1<0!!!', 'ig=', ig, 'l=', l, 'a=', alim(ig, l-1), 'e=', &
    1822           entr(ig, l-1), 'f=', fmc(ig, l-1), 'd=', detr(ig, l-1), 'f+1=', &
    1823           fmc(ig, l)
    1824       END IF
    1825     END DO
    1826   END DO
    1827   ! test de verification
    1828   DO ig = 1, ngrid
    1829     DO l = 1, lmax(ig)
    1830       IF ((abs(fmc(ig,l+1)-fmc(ig,l)-alim(ig,l)-entr(ig,l)+ &
    1831           detr(ig,l)))>1.E-4) THEN
    1832         ! PRINT*,'pbcm!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
    1833         ! s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
    1834         ! s  'f+1=',fmc(ig,l+1)
    1835       END IF
    1836       IF (detr(ig,l)<0.) THEN
    1837         PRINT *, 'detrdemi<0!!!'
    1838       END IF
    1839     END DO
    1840   END DO
    1841 
    1842   ! RC
    1843   ! CR def de  zmix continu (profil parabolique des vitesses)
    1844   DO ig = 1, ngrid
    1845     IF (lmix(ig)>1.) THEN
    1846       ! test
    1847       IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- &
    1848           (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- &
    1849           zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- &
    1850           (zlev(ig,lmix(ig)))))>1E-10) THEN
    1851 
    1852         zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) &
    1853           )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, &
    1854           lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ &
    1855           (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- &
    1856           (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- &
    1857           zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
    1858       ELSE
    1859         zmix(ig) = zlev(ig, lmix(ig))
    1860         PRINT *, 'pb zmix'
    1861       END IF
    1862     ELSE
    1863       zmix(ig) = 0.
    1864     END IF
    1865     ! test
    1866     IF ((zmax(ig)-zmix(ig))<=0.) THEN
    1867       zmix(ig) = 0.9*zmax(ig)
    1868       ! PRINT*,'pb zmix>zmax'
    1869     END IF
    1870   END DO
    1871   DO ig = 1, klon
    1872     zmix0(ig) = zmix(ig)
    1873   END DO
    1874 
    1875   ! calcul du nouveau lmix correspondant
    1876   DO ig = 1, ngrid
    1877     DO l = 1, klev
    1878       IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)<zlev(ig,l+1)) THEN
    1879         lmix(ig) = l
    1880       END IF
    1881     END DO
    1882   END DO
    1883 
    1884   ! ne devrait pas arriver!!!!!
    1885   DO ig = 1, ngrid
    1886     DO l = 1, klev
    1887       IF (detr(ig,l)>(fmc(ig,l)+alim(ig,l))+entr(ig,l)) THEN
    1888         PRINT *, 'detr2>fmc2!!!', 'ig=', ig, 'l=', l, 'd=', detr(ig, l), &
    1889           'f=', fmc(ig, l), 'lmax=', lmax(ig)
    1890         ! detr(ig,l)=fmc(ig,l)+alim(ig,l)+entr(ig,l)
    1891         ! entr(ig,l)=0.
    1892         ! fmc(ig,l+1)=0.
    1893         ! zw2(ig,l+1)=0.
    1894         ! zqla(ig,l+1)=0.
    1895         PRINT *, 'pb!fm=0 et f_star>0', l, lmax(ig)
    1896         ! lmax(ig)=l
    1897       END IF
    1898     END DO
    1899   END DO
    1900   DO ig = 1, ngrid
    1901     DO l = lmax(ig) + 1, klev + 1
    1902       ! fmc(ig,l)=0.
    1903       ! detr(ig,l)=0.
    1904       ! entr(ig,l)=0.
    1905       ! zw2(ig,l)=0.
    1906       ! zqla(ig,l)=0.
    1907     END DO
    1908   END DO
    1909 
    1910   ! Calcul du detrainement lors du premier passage
    1911   ! PRINT*,'9 OK convect8'
    1912   ! PRINT*,'WA1 ',wa_moy
    1913 
    1914   ! determination de l'indice du debut de la mixed layer ou w decroit
    1915 
    1916   ! calcul de la largeur de chaque ascendance dans le cas conservatif.
    1917   ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
    1918   ! d'une couche est égale à la hauteur de la couche alimentante.
    1919   ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
    1920   ! de la vitesse d'entrainement horizontal dans la couche alimentante.
    1921 
    1922   DO l = 2, nlay
    1923     DO ig = 1, ngrid
    1924       IF (l<=lmax(ig) .AND. (test(ig)==1)) THEN
    1925         zw = max(wa_moy(ig,l), 1.E-10)
    1926         larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw)
    1927       END IF
    1928     END DO
    1929   END DO
    1930 
    1931   DO l = 2, nlay
    1932     DO ig = 1, ngrid
    1933       IF (l<=lmax(ig) .AND. (test(ig)==1)) THEN
    1934         ! if (idetr.EQ.0) THEN
    1935         ! cette option est finalement en dur.
    1936         IF ((l_mix*zlev(ig,l))<0.) THEN
    1937           PRINT *, 'pb l_mix*zlev<0'
    1938         END IF
    1939         ! CR: test: nouvelle def de lambda
    1940         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    1941         IF (zw2(ig,l)>1.E-10) THEN
    1942           larg_detr(ig, l) = sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
    1943         ELSE
    1944           larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l))
    1945         END IF
    1946         ! ELSE IF (idetr.EQ.1) THEN
    1947         ! larg_detr(ig,l)=larg_cons(ig,l)
    1948         ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
    1949         ! ELSE IF (idetr.EQ.2) THEN
    1950         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    1951         ! s            *sqrt(wa_moy(ig,l))
    1952         ! ELSE IF (idetr.EQ.4) THEN
    1953         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    1954         ! s            *wa_moy(ig,l)
    1955         ! END IF
    1956       END IF
    1957     END DO
    1958   END DO
    1959 
    1960   ! PRINT*,'10 OK convect8'
    1961   ! PRINT*,'WA2 ',wa_moy
    1962   ! cal1cul de la fraction de la maille concernée par l'ascendance en tenant
    1963   ! compte de l'epluchage du thermique.
    1964 
    1965 
    1966   DO l = 2, nlay
    1967     DO ig = 1, ngrid
    1968       IF (larg_cons(ig,l)>1. .AND. (test(ig)==1)) THEN
    1969         ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
    1970         fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig))
    1971         ! test
    1972         fraca(ig, l) = max(fraca(ig,l), 0.)
    1973         fraca(ig, l) = min(fraca(ig,l), 0.5)
    1974         fracd(ig, l) = 1. - fraca(ig, l)
    1975         fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig))
    1976       ELSE
    1977         ! wa_moy(ig,l)=0.
    1978         fraca(ig, l) = 0.
    1979         fracc(ig, l) = 0.
    1980         fracd(ig, l) = 1.
    1981       END IF
    1982     END DO
    1983   END DO
    1984   ! CR: calcul de fracazmix
    1985   DO ig = 1, ngrid
    1986     IF (test(ig)==1) THEN
    1987       fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ &
    1988         (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + &
    1989         fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca( &
    1990         ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
    1991     END IF
    1992   END DO
    1993 
    1994   DO l = 2, nlay
    1995     DO ig = 1, ngrid
    1996       IF (larg_cons(ig,l)>1. .AND. (test(ig)==1)) THEN
    1997         IF (l>lmix(ig)) THEN
    1998           ! test
    1999           IF (zmax(ig)-zmix(ig)<1.E-10) THEN
    2000             ! PRINT*,'pb xxx'
    2001             xxx(ig, l) = (lmax(ig)+1.-l)/(lmax(ig)+1.-lmix(ig))
    2002           ELSE
    2003             xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
    2004           END IF
    2005           IF (idetr==0) THEN
    2006             fraca(ig, l) = fracazmix(ig)
    2007           ELSE IF (idetr==1) THEN
    2008             fraca(ig, l) = fracazmix(ig)*xxx(ig, l)
    2009           ELSE IF (idetr==2) THEN
    2010             fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
    2011           ELSE
    2012             fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2
    2013           END IF
    2014           ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
    2015           fraca(ig, l) = max(fraca(ig,l), 0.)
    2016           fraca(ig, l) = min(fraca(ig,l), 0.5)
    2017           fracd(ig, l) = 1. - fraca(ig, l)
    2018           fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig))
    2019         END IF
    2020       END IF
    2021     END DO
    2022   END DO
    2023 
    2024   PRINT *, 'fin calcul fraca'
    2025   ! PRINT*,'11 OK convect8'
    2026   ! PRINT*,'Ea3 ',wa_moy
    2027   ! ------------------------------------------------------------------
    2028   ! Calcul de fracd, wd
    2029   ! somme wa - wd = 0
    2030   ! ------------------------------------------------------------------
    2031 
    2032 
    2033   DO ig = 1, ngrid
    2034     fm(ig, 1) = 0.
    2035     fm(ig, nlay+1) = 0.
    2036   END DO
    2037 
    2038   DO l = 2, nlay
    2039     DO ig = 1, ngrid
    2040       IF (test(ig)==1) THEN
    2041         fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l)
    2042         ! CR:test
    2043         IF (alim(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) &
    2044             THEN
    2045           fm(ig, l) = fm(ig, l-1)
    2046           ! WRITE(1,*)'ajustement fm, l',l
    2047         END IF
    2048         ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
    2049         ! RC
    2050       END IF
    2051     END DO
    2052     DO ig = 1, ngrid
    2053       IF (fracd(ig,l)<0.1 .AND. (test(ig)==1)) THEN
    2054         abort_message = 'fracd trop petit'
    2055         CALL abort_physic(modname, abort_message, 1)
    2056       ELSE
    2057         ! vitesse descendante "diagnostique"
    2058         wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l))
    2059       END IF
    2060     END DO
    2061   END DO
    2062 
    2063   DO l = 1, nlay + 1
    2064     DO ig = 1, ngrid
    2065       IF (test(ig)==0) THEN
    2066         fm(ig, l) = fmc(ig, l)
    2067       END IF
    2068     END DO
    2069   END DO
    2070 
    2071   ! fin du first
    2072   DO l = 1, nlay
    2073     DO ig = 1, ngrid
    2074       ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    2075       masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg
    2076     END DO
    2077   END DO
    2078 
    2079   ! PRINT*,'12 OK convect8'
    2080   ! PRINT*,'WA4 ',wa_moy
    2081   ! c------------------------------------------------------------------
    2082   ! calcul du transport vertical
    2083   ! ------------------------------------------------------------------
    2084 
    2085   GO TO 4444
    2086   ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
    2087   DO l = 2, nlay - 1
    2088     DO ig = 1, ngrid
    2089       IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( &
    2090           ig,l+1)) THEN
    2091         PRINT *, 'WARN!!! FM>M ig=', ig, ' l=', l, '  FM=', &
    2092           fm(ig, l+1)*ptimestep, '   M=', masse(ig, l), masse(ig, l+1)
    2093       END IF
    2094     END DO
    2095   END DO
    2096 
    2097   DO l = 1, nlay
    2098     DO ig = 1, ngrid
    2099       IF ((alim(ig,l)+entr(ig,l))*ptimestep>masse(ig,l)) THEN
    2100         PRINT *, 'WARN!!! E>M ig=', ig, ' l=', l, '  E==', &
    2101           (entr(ig,l)+alim(ig,l))*ptimestep, '   M=', masse(ig, l)
    2102       END IF
    2103     END DO
    2104   END DO
    2105 
    2106   DO l = 1, nlay
    2107     DO ig = 1, ngrid
    2108       IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN
    2109         ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
    2110         ! s         ,'   FM=',fm(ig,l)
    2111       END IF
    2112       IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN
    2113         ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
    2114         ! s         ,'   M=',masse(ig,l)
    2115         ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
    2116         ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
    2117         ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
    2118         ! s                ,zlev(ig,l+1),zlev(ig,l)
    2119         ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
    2120         ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
    2121       END IF
    2122       IF (.NOT. alim(ig,l)>=0. .OR. .NOT. alim(ig,l)<=10.) THEN
    2123         ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
    2124         ! s         ,'   E=',entr(ig,l)
    2125       END IF
    2126     END DO
    2127   END DO
    2128 
    2129 4444 CONTINUE
    2130 
    2131   ! CR:redefinition du entr
    2132   ! CR:test:on ne change pas la def du entr mais la def du fm
    2133   DO l = 1, nlay
    2134     DO ig = 1, ngrid
    2135       IF (test(ig)==1) THEN
    2136         detr(ig, l) = fm(ig, l) + alim(ig, l) - fm(ig, l+1)
    2137         IF (detr(ig,l)<0.) THEN
    2138           ! entr(ig,l)=entr(ig,l)-detr(ig,l)
    2139           fm(ig, l+1) = fm(ig, l) + alim(ig, l)
    2140           detr(ig, l) = 0.
    2141           ! WRITE(11,*)'l,ig,entr',l,ig,entr(ig,l)
    2142           ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
    2143         END IF
    2144       END IF
    2145     END DO
    2146   END DO
    2147   ! RC
    2148 
    2149   IF (w2di==1) THEN
    2150     fm0 = fm0 + ptimestep*(fm-fm0)/tho
    2151     entr0 = entr0 + ptimestep*(alim+entr-entr0)/tho
    2152   ELSE
    2153     fm0 = fm
    2154     entr0 = alim + entr
    2155     detr0 = detr
    2156     alim0 = alim
    2157     ! zoa=zqta
    2158     ! entr0=alim
    2159   END IF
    2160 
    2161   IF (1==1) THEN
    2162     ! CALL dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
    2163     ! .    ,zh,zdhadj,zha)
    2164     ! CALL dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
    2165     ! .    ,zo,pdoadj,zoa)
    2166     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zthl, &
    2167       zdthladj, zta)
    2168     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, po, pdoadj, &
    2169       zoa)
    2170   ELSE
    2171     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
    2172       zdhadj, zha)
    2173     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
    2174       pdoadj, zoa)
    2175   END IF
    2176 
    2177   IF (1==0) THEN
    2178     CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
    2179       zu, zv, pduadj, pdvadj, zua, zva)
    2180   ELSE
    2181     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
    2182       zua)
    2183     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
    2184       zva)
    2185   END IF
    2186 
    2187   ! Calcul des moments
    2188   ! do l=1,nlay
    2189   ! do ig=1,ngrid
    2190   ! zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
    2191   ! zf2=zf/(1.-zf)
    2192   ! thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
    2193   ! wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
    2194   ! enddo
    2195   ! enddo
    2196 
    2197 
    2198 
    2199 
    2200 
    2201 
    2202   ! PRINT*,'13 OK convect8'
    2203   ! PRINT*,'WA5 ',wa_moy
    2204   DO l = 1, nlay
    2205     DO ig = 1, ngrid
    2206       ! pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
    2207       pdtadj(ig, l) = zdthladj(ig, l)*zpspsk(ig, l)
    2208     END DO
    2209   END DO
    2210 
    2211 
    2212   ! do l=1,nlay
    2213   ! do ig=1,ngrid
    2214   ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
    2215   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    2216   ! s         ,'   pdtadj=',pdtadj(ig,l)
    2217   ! END IF
    2218   ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
    2219   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    2220   ! s         ,'   pdoadj=',pdoadj(ig,l)
    2221   ! END IF
    2222   ! enddo
    2223   ! enddo
    2224 
    2225   ! PRINT*,'14 OK convect8'
    2226   ! ------------------------------------------------------------------
    2227   ! Calculs pour les sorties
    2228   ! ------------------------------------------------------------------
    2229   ! calcul de fraca pour les sorties
    2230   DO l = 2, klev
    2231     DO ig = 1, klon
    2232       IF (zw2(ig,l)>1.E-10) THEN
    2233         fraca(ig, l) = fm(ig, l)/(rhobarz(ig,l)*zw2(ig,l))
    2234       ELSE
    2235         fraca(ig, l) = 0.
    2236       END IF
    2237     END DO
    2238   END DO
    2239   IF (sorties) THEN
     3999
    22404000    DO l = 1, nlay
    22414001      DO ig = 1, ngrid
    2242         zla(ig, l) = (1.-fracd(ig,l))*zmax(ig)
    2243         zld(ig, l) = fracd(ig, l)*zmax(ig)
    2244         IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ &
    2245           (1.-fracd(ig,l))
    2246       END DO
    2247     END DO
    2248     ! CR calcul du niveau de condensation
    2249     ! initialisation
    2250     DO ig = 1, ngrid
    2251       nivcon(ig) = 0.
    2252       zcon(ig) = 0.
    2253     END DO
    2254     DO k = nlay, 1, -1
    2255       DO ig = 1, ngrid
    2256         IF (zqla(ig,k)>1E-10) THEN
    2257           nivcon(ig) = k
    2258           zcon(ig) = zlev(ig, k)
    2259         END IF
    2260         ! if (zcon(ig).gt.1.e-10) THEN
    2261         ! nuage=.TRUE.
    2262         ! else
    2263         ! nuage=.FALSE.
    2264         ! END IF
    2265       END DO
    2266     END DO
    2267 
     4002        zf = 0.5 * (fracc(ig, l) + fracc(ig, l + 1))
     4003        zf2 = zf / (1. - zf)
     4004        thetath2(ig, l) = zf2 * (zha(ig, l) - zh(ig, l))**2
     4005        wth2(ig, l) = zf2 * (0.5 * (wa_moy(ig, l) + wa_moy(ig, l + 1)))**2
     4006      END DO
     4007    END DO
     4008
     4009
     4010
     4011    ! PRINT*,'13 OK convect8'
     4012    ! PRINT*,'WA5 ',wa_moy
    22684013    DO l = 1, nlay
    22694014      DO ig = 1, ngrid
    2270         zf = fraca(ig, l)
    2271         zf2 = zf/(1.-zf)
    2272         thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2
    2273         wth2(ig, l) = zf2*(zw2(ig,l))**2
    2274         ! PRINT*,'wth2=',wth2(ig,l)
    2275         wth3(ig, l) = zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l))*zw2(ig, l)* &
    2276           zw2(ig, l)*zw2(ig, l)
    2277         q2(ig, l) = zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2
    2278         ! test: on calcul q2/po=ratqsc
    2279         ! if (nuage) THEN
    2280         ratqscth(ig, l) = sqrt(q2(ig,l))/(po(ig,l)*1000.)
    2281         ! else
    2282         ! ratqscth(ig,l)=0.
    2283         ! END IF
    2284       END DO
    2285     END DO
    2286     ! calcul du ratqscdiff
    2287     sum = 0.
    2288     sumdiff = 0.
    2289     ratqsdiff(:, :) = 0.
    2290     DO ig = 1, ngrid
    2291       DO l = 1, lentr(ig)
    2292         sum = sum + alim_star(ig, l)*zqta(ig, l)*1000.
    2293       END DO
    2294     END DO
    2295     DO ig = 1, ngrid
    2296       DO l = 1, lentr(ig)
    2297         zf = fraca(ig, l)
    2298         zf2 = zf/(1.-zf)
    2299         sumdiff = sumdiff + alim_star(ig, l)*(zqta(ig,l)*1000.-sum)**2
    2300         ! ratqsdiff=ratqsdiff+alim_star(ig,l)*
    2301         ! s          (zqta(ig,l)*1000.-po(ig,l)*1000.)**2
    2302       END DO
    2303     END DO
    2304     DO l = 1, klev
    2305       DO ig = 1, ngrid
    2306         ratqsdiff(ig, l) = sqrt(sumdiff)/(po(ig,l)*1000.)
    2307         ! WRITE(11,*)'ratqsdiff=',ratqsdiff(ig,l)
    2308       END DO
    2309     END DO
    2310 
    2311   END IF
    2312 
    2313   ! PRINT*,'19 OK convect8'
    2314 
    2315 END SUBROUTINE thermcell_cld
    2316 
    2317 SUBROUTINE thermcell_eau(ngrid, nlay, ptimestep, pplay, pplev, pphi, pu, pv, &
    2318     pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s
    2319                                                          ! ,pu_therm,pv_therm
    2320     , r_aspect, l_mix, w2di, tho)
    2321 
    2322   USE dimphy
    2323   IMPLICIT NONE
    2324 
    2325   ! =======================================================================
    2326 
    2327   ! Calcul du transport verticale dans la couche limite en presence
    2328   ! de "thermiques" explicitement representes
    2329 
    2330   ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
    2331 
    2332   ! le thermique est supposé homogène et dissipé par mélange avec
    2333   ! son environnement. la longueur l_mix contrôle l'efficacité du
    2334   ! mélange
    2335 
    2336   ! Le calcul du transport des différentes espèces se fait en prenant
    2337   ! en compte:
    2338   ! 1. un flux de masse montant
    2339   ! 2. un flux de masse descendant
    2340   ! 3. un entrainement
    2341   ! 4. un detrainement
    2342 
    2343   ! =======================================================================
    2344 
    2345   ! -----------------------------------------------------------------------
    2346   ! declarations:
    2347   ! -------------
    2348 
    2349   include "YOMCST.h"
    2350   include "YOETHF.h"
    2351   include "FCTTRE.h"
    2352 
    2353   ! arguments:
    2354   ! ----------
    2355 
    2356   INTEGER ngrid, nlay, w2di
    2357   REAL tho
    2358   REAL ptimestep, l_mix, r_aspect
    2359   REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
    2360   REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
    2361   REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
    2362   REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
    2363   REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1)
    2364   REAL pphi(ngrid, nlay)
    2365 
    2366   INTEGER idetr
    2367   SAVE idetr
    2368   DATA idetr/3/
    2369   !$OMP THREADPRIVATE(idetr)
    2370 
    2371   ! local:
    2372   ! ------
    2373 
    2374   INTEGER ig, k, l, lmaxa(klon), lmix(klon)
    2375   REAL zsortie1d(klon)
    2376   ! CR: on remplace lmax(klon,klev+1)
    2377   INTEGER lmax(klon), lmin(klon), lentr(klon)
    2378   REAL linter(klon)
    2379   REAL zmix(klon), fracazmix(klon)
    2380   ! RC
    2381   REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz
    2382 
    2383   REAL zlev(klon, klev+1), zlay(klon, klev)
    2384   REAL zh(klon, klev), zdhadj(klon, klev)
    2385   REAL zthl(klon, klev), zdthladj(klon, klev)
    2386   REAL ztv(klon, klev)
    2387   REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
    2388   REAL zl(klon, klev)
    2389   REAL wh(klon, klev+1)
    2390   REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1)
    2391   REAL zla(klon, klev+1)
    2392   REAL zwa(klon, klev+1)
    2393   REAL zld(klon, klev+1)
    2394   REAL zwd(klon, klev+1)
    2395   REAL zsortie(klon, klev)
    2396   REAL zva(klon, klev)
    2397   REAL zua(klon, klev)
    2398   REAL zoa(klon, klev)
    2399 
    2400   REAL zta(klon, klev)
    2401   REAL zha(klon, klev)
    2402   REAL wa_moy(klon, klev+1)
    2403   REAL fraca(klon, klev+1)
    2404   REAL fracc(klon, klev+1)
    2405   REAL zf, zf2
    2406   REAL thetath2(klon, klev), wth2(klon, klev)
    2407   ! common/comtherm/thetath2,wth2
    2408 
    2409   REAL count_time
    2410   INTEGER ialt
    2411 
    2412   LOGICAL sorties
    2413   REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev)
    2414   REAL zpspsk(klon, klev)
    2415 
    2416   ! real wmax(klon,klev),wmaxa(klon)
    2417   REAL wmax(klon), wmaxa(klon)
    2418   REAL wa(klon, klev, klev+1)
    2419   REAL wd(klon, klev+1)
    2420   REAL larg_part(klon, klev, klev+1)
    2421   REAL fracd(klon, klev+1)
    2422   REAL xxx(klon, klev+1)
    2423   REAL larg_cons(klon, klev+1)
    2424   REAL larg_detr(klon, klev+1)
    2425   REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev)
    2426   REAL pu_therm(klon, klev), pv_therm(klon, klev)
    2427   REAL fm(klon, klev+1), entr(klon, klev)
    2428   REAL fmc(klon, klev+1)
    2429 
    2430   REAL zcor, zdelta, zcvm5, qlbef
    2431   REAL tbef(klon), qsatbef(klon)
    2432   REAL dqsat_dt, dt, num, denom
    2433   REAL reps, rlvcp, ddt0
    2434   REAL ztla(klon, klev), zqla(klon, klev), zqta(klon, klev)
    2435 
    2436   PARAMETER (ddt0=.01)
    2437 
    2438   ! CR:nouvelles variables
    2439   REAL f_star(klon, klev+1), entr_star(klon, klev)
    2440   REAL entr_star_tot(klon), entr_star2(klon)
    2441   REAL f(klon), f0(klon)
    2442   REAL zlevinter(klon)
    2443   LOGICAL first
    2444   DATA first/.FALSE./
    2445   SAVE first
    2446   !$OMP THREADPRIVATE(first)
    2447 
    2448   ! RC
    2449 
    2450   CHARACTER *2 str2
    2451   CHARACTER *10 str10
    2452 
    2453   CHARACTER (LEN=20) :: modname = 'thermcell_eau'
    2454   CHARACTER (LEN=80) :: abort_message
    2455 
    2456   LOGICAL vtest(klon), down
    2457   LOGICAL zsat(klon)
    2458 
    2459   EXTERNAL scopy
    2460 
    2461   INTEGER ncorrec, ll
    2462   SAVE ncorrec
    2463   DATA ncorrec/0/
    2464   !$OMP THREADPRIVATE(ncorrec)
    2465 
    2466 
    2467 
    2468   ! -----------------------------------------------------------------------
    2469   ! initialisation:
    2470   ! ---------------
    2471 
    2472   sorties = .TRUE.
    2473   IF (ngrid/=klon) THEN
    2474     PRINT *
    2475     PRINT *, 'STOP dans convadj'
    2476     PRINT *, 'ngrid    =', ngrid
    2477     PRINT *, 'klon  =', klon
    2478   END IF
    2479 
    2480   ! Initialisation
    2481   rlvcp = rlvtt/rcpd
    2482   reps = rd/rv
    2483 
    2484   ! -----------------------------------------------------------------------
    2485   ! AM Calcul de T,q,ql a partir de Tl et qT
    2486   ! ---------------------------------------------------
    2487 
    2488   ! Pr Tprec=Tl calcul de qsat
    2489   ! Si qsat>qT T=Tl, q=qT
    2490   ! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt)
    2491   ! On cherche DDT < DDT0
    2492 
    2493   ! defaut
    2494   DO ll = 1, nlay
    2495     DO ig = 1, ngrid
    2496       zo(ig, ll) = po(ig, ll)
    2497       zl(ig, ll) = 0.
    2498       zh(ig, ll) = pt(ig, ll)
    2499     END DO
    2500   END DO
    2501   DO ig = 1, ngrid
    2502     zsat(ig) = .FALSE.
    2503   END DO
    2504 
    2505 
    2506   DO ll = 1, nlay
    2507     ! les points insatures sont definitifs
    2508     DO ig = 1, ngrid
    2509       tbef(ig) = pt(ig, ll)
    2510       zdelta = max(0., sign(1.,rtt-tbef(ig)))
    2511       qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll)
    2512       qsatbef(ig) = min(0.5, qsatbef(ig))
    2513       zcor = 1./(1.-retv*qsatbef(ig))
    2514       qsatbef(ig) = qsatbef(ig)*zcor
    2515       zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig))>0.00001)
    2516     END DO
    2517 
    2518     DO ig = 1, ngrid
    2519       IF (zsat(ig)) THEN
    2520         qlbef = max(0., po(ig,ll)-qsatbef(ig))
    2521         ! si sature: ql est surestime, d'ou la sous-relax
    2522         dt = 0.5*rlvcp*qlbef
    2523         ! on pourra enchainer 2 ou 3 calculs sans Do while
    2524         DO WHILE (dt>ddt0)
    2525           ! il faut verifier si c,a conserve quand on repasse en insature ...
    2526           tbef(ig) = tbef(ig) + dt
    2527           zdelta = max(0., sign(1.,rtt-tbef(ig)))
    2528           qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll)
    2529           qsatbef(ig) = min(0.5, qsatbef(ig))
    2530           zcor = 1./(1.-retv*qsatbef(ig))
    2531           qsatbef(ig) = qsatbef(ig)*zcor
    2532           ! on veut le signe de qlbef
    2533           qlbef = po(ig, ll) - qsatbef(ig)
    2534           ! dqsat_dT
    2535           zdelta = max(0., sign(1.,rtt-tbef(ig)))
    2536           zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta
    2537           zcor = 1./(1.-retv*qsatbef(ig))
    2538           dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor)
    2539           num = -tbef(ig) + pt(ig, ll) + rlvcp*qlbef
    2540           denom = 1. + rlvcp*dqsat_dt
    2541           dt = num/denom
    2542         END DO
    2543         ! on ecrit de maniere conservative (sat ou non)
    2544         zl(ig, ll) = max(0., qlbef)
    2545         ! T = Tl +Lv/Cp ql
    2546         zh(ig, ll) = pt(ig, ll) + rlvcp*zl(ig, ll)
    2547         zo(ig, ll) = po(ig, ll) - zl(ig, ll)
    2548       END IF
    2549     END DO
    2550   END DO
    2551   ! AM fin
    2552 
    2553   ! -----------------------------------------------------------------------
    2554   ! incrementation eventuelle de tendances precedentes:
    2555   ! ---------------------------------------------------
    2556 
    2557   ! PRINT*,'0 OK convect8'
    2558 
    2559   DO l = 1, nlay
    2560     DO ig = 1, ngrid
    2561       zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa
    2562       ! zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
    2563       zu(ig, l) = pu(ig, l)
    2564       zv(ig, l) = pv(ig, l)
    2565       ! zo(ig,l)=po(ig,l)
    2566       ! ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
    2567       ! AM attention zh est maintenant le profil de T et plus le profil de
    2568       ! theta !
    2569 
    2570       ! T-> Theta
    2571       ztv(ig, l) = zh(ig, l)/zpspsk(ig, l)
    2572       ! AM Theta_v
    2573       ztv(ig, l) = ztv(ig, l)*(1.+retv*(zo(ig,l))-zl(ig,l))
    2574       ! AM Thetal
    2575       zthl(ig, l) = pt(ig, l)/zpspsk(ig, l)
    2576 
    2577     END DO
    2578   END DO
    2579 
    2580   ! PRINT*,'1 OK convect8'
    2581   ! --------------------
    2582 
    2583 
    2584   ! + + + + + + + + + + +
    2585 
    2586 
    2587   ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
    2588   ! wh,wt,wo ...
    2589 
    2590   ! + + + + + + + + + + +  zh,zu,zv,zo,rho
    2591 
    2592 
    2593   ! --------------------   zlev(1)
    2594   ! \\\\\\\\\\\\\\\\\\\\
    2595 
    2596 
    2597 
    2598   ! -----------------------------------------------------------------------
    2599   ! Calcul des altitudes des couches
    2600   ! -----------------------------------------------------------------------
    2601 
    2602   DO l = 2, nlay
    2603     DO ig = 1, ngrid
    2604       zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg
    2605     END DO
    2606   END DO
    2607   DO ig = 1, ngrid
    2608     zlev(ig, 1) = 0.
    2609     zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg
    2610   END DO
    2611   DO l = 1, nlay
    2612     DO ig = 1, ngrid
    2613       zlay(ig, l) = pphi(ig, l)/rg
    2614     END DO
    2615   END DO
    2616 
    2617   ! PRINT*,'2 OK convect8'
    2618   ! -----------------------------------------------------------------------
    2619   ! Calcul des densites
    2620   ! -----------------------------------------------------------------------
    2621 
    2622   DO l = 1, nlay
    2623     DO ig = 1, ngrid
    2624       ! rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
    2625       rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*ztv(ig,l))
    2626     END DO
    2627   END DO
    2628 
    2629   DO l = 2, nlay
    2630     DO ig = 1, ngrid
    2631       rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1))
    2632     END DO
    2633   END DO
    2634 
    2635   DO k = 1, nlay
    2636     DO l = 1, nlay + 1
    2637       DO ig = 1, ngrid
    2638         wa(ig, k, l) = 0.
    2639       END DO
    2640     END DO
    2641   END DO
    2642 
    2643   ! PRINT*,'3 OK convect8'
    2644   ! ------------------------------------------------------------------
    2645   ! Calcul de w2, quarre de w a partir de la cape
    2646   ! a partir de w2, on calcule wa, vitesse de l'ascendance
    2647 
    2648   ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
    2649   ! w2 est stoke dans wa
    2650 
    2651   ! ATTENTION: dans convect8, on n'utilise le calcule des wa
    2652   ! independants par couches que pour calculer l'entrainement
    2653   ! a la base et la hauteur max de l'ascendance.
    2654 
    2655   ! Indicages:
    2656   ! l'ascendance provenant du niveau k traverse l'interface l avec
    2657   ! une vitesse wa(k,l).
    2658 
    2659   ! --------------------
    2660 
    2661   ! + + + + + + + + + +
    2662 
    2663   ! wa(k,l)   ----       --------------------    l
    2664   ! /\
    2665   ! /||\       + + + + + + + + + +
    2666   ! ||
    2667   ! ||        --------------------
    2668   ! ||
    2669   ! ||        + + + + + + + + + +
    2670   ! ||
    2671   ! ||        --------------------
    2672   ! ||__
    2673   ! |___      + + + + + + + + + +     k
    2674 
    2675   ! --------------------
    2676 
    2677 
    2678 
    2679   ! ------------------------------------------------------------------
    2680 
    2681   ! CR: ponderation entrainement des couches instables
    2682   ! def des entr_star tels que entr=f*entr_star
    2683   DO l = 1, klev
    2684     DO ig = 1, ngrid
    2685       entr_star(ig, l) = 0.
    2686     END DO
    2687   END DO
    2688   ! determination de la longueur de la couche d entrainement
    2689   DO ig = 1, ngrid
    2690     lentr(ig) = 1
    2691   END DO
    2692 
    2693   ! on ne considere que les premieres couches instables
    2694   DO k = nlay - 1, 1, -1
    2695     DO ig = 1, ngrid
    2696       IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<ztv(ig,k+2)) THEN
    2697         lentr(ig) = k
    2698       END IF
    2699     END DO
    2700   END DO
    2701 
    2702   ! determination du lmin: couche d ou provient le thermique
    2703   DO ig = 1, ngrid
    2704     lmin(ig) = 1
    2705   END DO
    2706   DO ig = 1, ngrid
    2707     DO l = nlay, 2, -1
    2708       IF (ztv(ig,l-1)>ztv(ig,l)) THEN
    2709         lmin(ig) = l - 1
    2710       END IF
    2711     END DO
    2712   END DO
    2713 
    2714   ! definition de l'entrainement des couches
    2715   DO l = 1, klev - 1
    2716     DO ig = 1, ngrid
    2717       IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN
    2718         entr_star(ig, l) = (ztv(ig,l)-ztv(ig,l+1))*(zlev(ig,l+1)-zlev(ig,l))
    2719       END IF
    2720     END DO
    2721   END DO
    2722   ! pas de thermique si couche 1 stable
    2723   DO ig = 1, ngrid
    2724     IF (lmin(ig)>1) THEN
    2725       DO l = 1, klev
    2726         entr_star(ig, l) = 0.
    2727       END DO
    2728     END IF
    2729   END DO
    2730   ! calcul de l entrainement total
    2731   DO ig = 1, ngrid
    2732     entr_star_tot(ig) = 0.
    2733   END DO
    2734   DO ig = 1, ngrid
    2735     DO k = 1, klev
    2736       entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k)
    2737     END DO
    2738   END DO
    2739 
    2740   DO k = 1, klev
    2741     DO ig = 1, ngrid
    2742       ztva(ig, k) = ztv(ig, k)
    2743     END DO
    2744   END DO
    2745   ! RC
    2746   ! AM:initialisations
    2747   DO k = 1, nlay
    2748     DO ig = 1, ngrid
    2749       ztva(ig, k) = ztv(ig, k)
    2750       ztla(ig, k) = zthl(ig, k)
    2751       zqla(ig, k) = 0.
    2752       zqta(ig, k) = po(ig, k)
    2753       zsat(ig) = .FALSE.
    2754     END DO
    2755   END DO
    2756 
    2757   ! PRINT*,'7 OK convect8'
    2758   DO k = 1, klev + 1
    2759     DO ig = 1, ngrid
    2760       zw2(ig, k) = 0.
    2761       fmc(ig, k) = 0.
    2762       ! CR
    2763       f_star(ig, k) = 0.
    2764       ! RC
    2765       larg_cons(ig, k) = 0.
    2766       larg_detr(ig, k) = 0.
    2767       wa_moy(ig, k) = 0.
    2768     END DO
    2769   END DO
    2770 
    2771   ! PRINT*,'8 OK convect8'
    2772   DO ig = 1, ngrid
    2773     linter(ig) = 1.
    2774     lmaxa(ig) = 1
    2775     lmix(ig) = 1
    2776     wmaxa(ig) = 0.
    2777   END DO
    2778 
    2779   ! CR:
    2780   DO l = 1, nlay - 2
    2781     DO ig = 1, ngrid
    2782       IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. &
    2783           zw2(ig,l)<1E-10) THEN
    2784         ! AM
    2785         ztla(ig, l) = zthl(ig, l)
    2786         zqta(ig, l) = po(ig, l)
    2787         zqla(ig, l) = zl(ig, l)
    2788         ! AM
    2789         f_star(ig, l+1) = entr_star(ig, l)
    2790         ! test:calcul de dteta
    2791         zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* &
    2792           (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l))
    2793         larg_detr(ig, l) = 0.
    2794       ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, &
    2795           l)>1.E-10)) THEN
    2796         f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l)
    2797 
    2798         ! AM on melange Tl et qt du thermique
    2799         ztla(ig, l) = (f_star(ig,l)*ztla(ig,l-1)+entr_star(ig,l)*zthl(ig,l))/ &
    2800           f_star(ig, l+1)
    2801         zqta(ig, l) = (f_star(ig,l)*zqta(ig,l-1)+entr_star(ig,l)*po(ig,l))/ &
    2802           f_star(ig, l+1)
    2803 
    2804         ! ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
    2805         ! s                    *ztv(ig,l))/f_star(ig,l+1)
    2806 
    2807         ! AM on en deduit thetav et ql du thermique
    2808         tbef(ig) = ztla(ig, l)*zpspsk(ig, l)
    2809         zdelta = max(0., sign(1.,rtt-tbef(ig)))
    2810         qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l)
    2811         qsatbef(ig) = min(0.5, qsatbef(ig))
    2812         zcor = 1./(1.-retv*qsatbef(ig))
    2813         qsatbef(ig) = qsatbef(ig)*zcor
    2814         zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig))>0.00001)
    2815       END IF
    2816     END DO
    2817     DO ig = 1, ngrid
    2818       IF (zsat(ig)) THEN
    2819         qlbef = max(0., zqta(ig,l)-qsatbef(ig))
    2820         dt = 0.5*rlvcp*qlbef
    2821         DO WHILE (dt>ddt0)
    2822           tbef(ig) = tbef(ig) + dt
    2823           zdelta = max(0., sign(1.,rtt-tbef(ig)))
    2824           qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l)
    2825           qsatbef(ig) = min(0.5, qsatbef(ig))
    2826           zcor = 1./(1.-retv*qsatbef(ig))
    2827           qsatbef(ig) = qsatbef(ig)*zcor
    2828           qlbef = zqta(ig, l) - qsatbef(ig)
    2829 
    2830           zdelta = max(0., sign(1.,rtt-tbef(ig)))
    2831           zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta
    2832           zcor = 1./(1.-retv*qsatbef(ig))
    2833           dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor)
    2834           num = -tbef(ig) + ztla(ig, l)*zpspsk(ig, l) + rlvcp*qlbef
    2835           denom = 1. + rlvcp*dqsat_dt
    2836           dt = num/denom
    2837         END DO
    2838         zqla(ig, l) = max(0., zqta(ig,l)-qsatbef(ig))
    2839       END IF
    2840       ! on ecrit de maniere conservative (sat ou non)
    2841       ! T = Tl +Lv/Cp ql
    2842       ztva(ig, l) = ztla(ig, l)*zpspsk(ig, l) + rlvcp*zqla(ig, l)
    2843       ztva(ig, l) = ztva(ig, l)/zpspsk(ig, l)
    2844       ztva(ig, l) = ztva(ig, l)*(1.+retv*(zqta(ig,l)-zqla(ig,l))-zqla(ig,l))
    2845 
    2846     END DO
    2847     DO ig = 1, ngrid
    2848       IF (zw2(ig,l)>=1.E-10 .AND. f_star(ig,l)+entr_star(ig,l)>1.E-10) THEN
    2849         ! mise a jour de la vitesse ascendante (l'air entraine de la couche
    2850         ! consideree commence avec une vitesse nulle).
    2851 
    2852         zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + &
    2853           2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l))
    2854       END IF
    2855       ! determination de zmax continu par interpolation lineaire
    2856       IF (zw2(ig,l+1)<0.) THEN
    2857         linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( &
    2858           ig,l))
    2859         zw2(ig, l+1) = 0.
    2860         lmaxa(ig) = l
    2861       ELSE
    2862         wa_moy(ig, l+1) = sqrt(zw2(ig,l+1))
    2863       END IF
    2864       IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN
    2865         ! lmix est le niveau de la couche ou w (wa_moy) est maximum
    2866         lmix(ig) = l + 1
    2867         wmaxa(ig) = wa_moy(ig, l+1)
    2868       END IF
    2869     END DO
    2870   END DO
    2871 
    2872   ! Calcul de la couche correspondant a la hauteur du thermique
    2873   DO ig = 1, ngrid
    2874     lmax(ig) = lentr(ig)
    2875   END DO
    2876   DO ig = 1, ngrid
    2877     DO l = nlay, lentr(ig) + 1, -1
    2878       IF (zw2(ig,l)<=1.E-10) THEN
    2879         lmax(ig) = l - 1
    2880       END IF
    2881     END DO
    2882   END DO
    2883   ! pas de thermique si couche 1 stable
    2884   DO ig = 1, ngrid
    2885     IF (lmin(ig)>1) THEN
    2886       lmax(ig) = 1
    2887       lmin(ig) = 1
    2888     END IF
    2889   END DO
    2890 
    2891   ! Determination de zw2 max
    2892   DO ig = 1, ngrid
    2893     wmax(ig) = 0.
    2894   END DO
    2895 
    2896   DO l = 1, nlay
    2897     DO ig = 1, ngrid
    2898       IF (l<=lmax(ig)) THEN
    2899         zw2(ig, l) = sqrt(zw2(ig,l))
    2900         wmax(ig) = max(wmax(ig), zw2(ig,l))
    2901       ELSE
    2902         zw2(ig, l) = 0.
    2903       END IF
    2904     END DO
    2905   END DO
    2906 
    2907   ! Longueur caracteristique correspondant a la hauteur des thermiques.
    2908   DO ig = 1, ngrid
    2909     zmax(ig) = 500.
    2910     zlevinter(ig) = zlev(ig, 1)
    2911   END DO
    2912   DO ig = 1, ngrid
    2913     ! calcul de zlevinter
    2914     zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + &
    2915       zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
    2916     zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig)))
    2917   END DO
    2918 
    2919   ! Fermeture,determination de f
    2920   DO ig = 1, ngrid
    2921     entr_star2(ig) = 0.
    2922   END DO
    2923   DO ig = 1, ngrid
    2924     IF (entr_star_tot(ig)<1.E-10) THEN
    2925       f(ig) = 0.
    2926     ELSE
    2927       DO k = lmin(ig), lentr(ig)
    2928         entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( &
    2929           zlev(ig,k+1)-zlev(ig,k)))
    2930       END DO
    2931       ! Nouvelle fermeture
    2932       f(ig) = wmax(ig)/(zmax(ig)*r_aspect*entr_star2(ig))*entr_star_tot(ig)
    2933       ! test
    2934       IF (first) THEN
    2935         f(ig) = f(ig) + (f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)*wmax(ig))
    2936       END IF
    2937     END IF
    2938     f0(ig) = f(ig)
    2939     first = .TRUE.
    2940   END DO
    2941 
    2942   ! Calcul de l'entrainement
    2943   DO k = 1, klev
    2944     DO ig = 1, ngrid
    2945       entr(ig, k) = f(ig)*entr_star(ig, k)
    2946     END DO
    2947   END DO
    2948   ! Calcul des flux
    2949   DO ig = 1, ngrid
    2950     DO l = 1, lmax(ig) - 1
    2951       fmc(ig, l+1) = fmc(ig, l) + entr(ig, l)
    2952     END DO
    2953   END DO
    2954 
    2955   ! RC
    2956 
    2957 
    2958   ! PRINT*,'9 OK convect8'
    2959   ! PRINT*,'WA1 ',wa_moy
    2960 
    2961   ! determination de l'indice du debut de la mixed layer ou w decroit
    2962 
    2963   ! calcul de la largeur de chaque ascendance dans le cas conservatif.
    2964   ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
    2965   ! d'une couche est égale à la hauteur de la couche alimentante.
    2966   ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
    2967   ! de la vitesse d'entrainement horizontal dans la couche alimentante.
    2968 
    2969   DO l = 2, nlay
    2970     DO ig = 1, ngrid
    2971       IF (l<=lmaxa(ig)) THEN
    2972         zw = max(wa_moy(ig,l), 1.E-10)
    2973         larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw)
    2974       END IF
    2975     END DO
    2976   END DO
    2977 
    2978   DO l = 2, nlay
    2979     DO ig = 1, ngrid
    2980       IF (l<=lmaxa(ig)) THEN
    2981         ! if (idetr.EQ.0) THEN
    2982         ! cette option est finalement en dur.
    2983         larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l))
    2984         ! ELSE IF (idetr.EQ.1) THEN
    2985         ! larg_detr(ig,l)=larg_cons(ig,l)
    2986         ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
    2987         ! ELSE IF (idetr.EQ.2) THEN
    2988         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    2989         ! s            *sqrt(wa_moy(ig,l))
    2990         ! ELSE IF (idetr.EQ.4) THEN
    2991         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    2992         ! s            *wa_moy(ig,l)
    2993         ! END IF
    2994       END IF
    2995     END DO
    2996   END DO
    2997 
    2998   ! PRINT*,'10 OK convect8'
    2999   ! PRINT*,'WA2 ',wa_moy
    3000   ! calcul de la fraction de la maille concernée par l'ascendance en tenant
    3001   ! compte de l'epluchage du thermique.
    3002 
    3003   ! CR def de  zmix continu (profil parabolique des vitesses)
    3004   DO ig = 1, ngrid
    3005     IF (lmix(ig)>1.) THEN
    3006       zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig))) &
    3007         **2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, &
    3008         lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ &
    3009         (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- &
    3010         (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))*((zlev( &
    3011         ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
    3012     ELSE
    3013       zmix(ig) = 0.
    3014     END IF
    3015   END DO
    3016 
    3017   ! calcul du nouveau lmix correspondant
    3018   DO ig = 1, ngrid
    3019     DO l = 1, klev
    3020       IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)<zlev(ig,l+1)) THEN
    3021         lmix(ig) = l
    3022       END IF
    3023     END DO
    3024   END DO
    3025 
    3026   DO l = 2, nlay
    3027     DO ig = 1, ngrid
    3028       IF (larg_cons(ig,l)>1.) THEN
    3029         ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
    3030         fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig))
    3031         ! test
    3032         fraca(ig, l) = max(fraca(ig,l), 0.)
    3033         fraca(ig, l) = min(fraca(ig,l), 0.5)
    3034         fracd(ig, l) = 1. - fraca(ig, l)
    3035         fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig))
    3036       ELSE
    3037         ! wa_moy(ig,l)=0.
    3038         fraca(ig, l) = 0.
    3039         fracc(ig, l) = 0.
    3040         fracd(ig, l) = 1.
    3041       END IF
    3042     END DO
    3043   END DO
    3044   ! CR: calcul de fracazmix
    3045   DO ig = 1, ngrid
    3046     fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ &
    3047       (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + &
    3048       fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig &
    3049       ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
    3050   END DO
    3051 
    3052   DO l = 2, nlay
    3053     DO ig = 1, ngrid
    3054       IF (larg_cons(ig,l)>1.) THEN
    3055         IF (l>lmix(ig)) THEN
    3056           xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
    3057           IF (idetr==0) THEN
    3058             fraca(ig, l) = fracazmix(ig)
    3059           ELSE IF (idetr==1) THEN
    3060             fraca(ig, l) = fracazmix(ig)*xxx(ig, l)
    3061           ELSE IF (idetr==2) THEN
    3062             fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
    3063           ELSE
    3064             fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2
    3065           END IF
    3066           ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
    3067           fraca(ig, l) = max(fraca(ig,l), 0.)
    3068           fraca(ig, l) = min(fraca(ig,l), 0.5)
    3069           fracd(ig, l) = 1. - fraca(ig, l)
    3070           fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig))
    3071         END IF
    3072       END IF
    3073     END DO
    3074   END DO
    3075 
    3076   ! PRINT*,'11 OK convect8'
    3077   ! PRINT*,'Ea3 ',wa_moy
    3078   ! ------------------------------------------------------------------
    3079   ! Calcul de fracd, wd
    3080   ! somme wa - wd = 0
    3081   ! ------------------------------------------------------------------
    3082 
    3083 
    3084   DO ig = 1, ngrid
    3085     fm(ig, 1) = 0.
    3086     fm(ig, nlay+1) = 0.
    3087   END DO
    3088 
    3089   DO l = 2, nlay
    3090     DO ig = 1, ngrid
    3091       fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l)
    3092       ! CR:test
    3093       IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN
    3094         fm(ig, l) = fm(ig, l-1)
    3095         ! WRITE(1,*)'ajustement fm, l',l
    3096       END IF
    3097       ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
    3098       ! RC
    3099     END DO
    3100     DO ig = 1, ngrid
    3101       IF (fracd(ig,l)<0.1) THEN
    3102         abort_message = 'fracd trop petit'
    3103         CALL abort_physic(modname, abort_message, 1)
    3104       ELSE
    3105         ! vitesse descendante "diagnostique"
    3106         wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l))
    3107       END IF
    3108     END DO
    3109   END DO
    3110 
    3111   DO l = 1, nlay
    3112     DO ig = 1, ngrid
    3113       ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    3114       masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg
    3115     END DO
    3116   END DO
    3117 
    3118   ! PRINT*,'12 OK convect8'
    3119   ! PRINT*,'WA4 ',wa_moy
    3120   ! c------------------------------------------------------------------
    3121   ! calcul du transport vertical
    3122   ! ------------------------------------------------------------------
    3123 
    3124   GO TO 4444
    3125   ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
    3126   DO l = 2, nlay - 1
    3127     DO ig = 1, ngrid
    3128       IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( &
    3129           ig,l+1)) THEN
    3130         ! PRINT*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
    3131         ! s         ,fm(ig,l+1)*ptimestep
    3132         ! s         ,'   M=',masse(ig,l),masse(ig,l+1)
    3133       END IF
    3134     END DO
    3135   END DO
    3136 
    3137   DO l = 1, nlay
    3138     DO ig = 1, ngrid
    3139       IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN
    3140         ! PRINT*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
    3141         ! s         ,entr(ig,l)*ptimestep
    3142         ! s         ,'   M=',masse(ig,l)
    3143       END IF
    3144     END DO
    3145   END DO
    3146 
    3147   DO l = 1, nlay
    3148     DO ig = 1, ngrid
    3149       IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN
    3150         ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
    3151         ! s         ,'   FM=',fm(ig,l)
    3152       END IF
    3153       IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN
    3154         ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
    3155         ! s         ,'   M=',masse(ig,l)
    3156         ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
    3157         ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
    3158         ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
    3159         ! s                ,zlev(ig,l+1),zlev(ig,l)
    3160         ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
    3161         ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
    3162       END IF
    3163       IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN
    3164         ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
    3165         ! s         ,'   E=',entr(ig,l)
    3166       END IF
    3167     END DO
    3168   END DO
    3169 
    3170 4444 CONTINUE
    3171 
    3172   IF (w2di==1) THEN
    3173     fm0 = fm0 + ptimestep*(fm-fm0)/tho
    3174     entr0 = entr0 + ptimestep*(entr-entr0)/tho
    3175   ELSE
    3176     fm0 = fm
    3177     entr0 = entr
    3178   END IF
    3179 
    3180   IF (1==1) THEN
    3181     ! CALL dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
    3182     ! .    ,zh,zdhadj,zha)
    3183     ! CALL dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
    3184     ! .    ,zo,pdoadj,zoa)
    3185     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zthl, &
    3186       zdthladj, zta)
    3187     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, po, pdoadj, &
    3188       zoa)
    3189   ELSE
    3190     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
    3191       zdhadj, zha)
    3192     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
    3193       pdoadj, zoa)
    3194   END IF
    3195 
    3196   IF (1==0) THEN
    3197     CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
    3198       zu, zv, pduadj, pdvadj, zua, zva)
    3199   ELSE
    3200     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
    3201       zua)
    3202     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
    3203       zva)
    3204   END IF
    3205 
    3206   DO l = 1, nlay
    3207     DO ig = 1, ngrid
    3208       zf = 0.5*(fracc(ig,l)+fracc(ig,l+1))
    3209       zf2 = zf/(1.-zf)
    3210       thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2
    3211       wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
    3212     END DO
    3213   END DO
    3214 
    3215 
    3216 
    3217   ! PRINT*,'13 OK convect8'
    3218   ! PRINT*,'WA5 ',wa_moy
    3219   DO l = 1, nlay
    3220     DO ig = 1, ngrid
    3221       ! pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
    3222       pdtadj(ig, l) = zdthladj(ig, l)*zpspsk(ig, l)
    3223     END DO
    3224   END DO
    3225 
    3226 
    3227   ! do l=1,nlay
    3228   ! do ig=1,ngrid
    3229   ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
    3230   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    3231   ! s         ,'   pdtadj=',pdtadj(ig,l)
    3232   ! END IF
    3233   ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
    3234   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    3235   ! s         ,'   pdoadj=',pdoadj(ig,l)
    3236   ! END IF
    3237   ! enddo
    3238   ! enddo
    3239 
    3240   ! PRINT*,'14 OK convect8'
    3241   ! ------------------------------------------------------------------
    3242   ! Calculs pour les sorties
    3243   ! ------------------------------------------------------------------
    3244 
    3245 
    3246 END SUBROUTINE thermcell_eau
    3247 
    3248 SUBROUTINE thermcell(ngrid, nlay, ptimestep, pplay, pplev, pphi, pu, pv, pt, &
    3249     po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s
    3250                                                      ! ,pu_therm,pv_therm
    3251     , r_aspect, l_mix, w2di, tho)
    3252 
    3253   USE dimphy
    3254   IMPLICIT NONE
    3255 
    3256   ! =======================================================================
    3257 
    3258   ! Calcul du transport verticale dans la couche limite en presence
    3259   ! de "thermiques" explicitement representes
    3260 
    3261   ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
    3262 
    3263   ! le thermique est supposé homogène et dissipé par mélange avec
    3264   ! son environnement. la longueur l_mix contrôle l'efficacité du
    3265   ! mélange
    3266 
    3267   ! Le calcul du transport des différentes espèces se fait en prenant
    3268   ! en compte:
    3269   ! 1. un flux de masse montant
    3270   ! 2. un flux de masse descendant
    3271   ! 3. un entrainement
    3272   ! 4. un detrainement
    3273 
    3274   ! =======================================================================
    3275 
    3276   ! -----------------------------------------------------------------------
    3277   ! declarations:
    3278   ! -------------
    3279 
    3280   include "YOMCST.h"
    3281 
    3282   ! arguments:
    3283   ! ----------
    3284 
    3285   INTEGER ngrid, nlay, w2di
    3286   REAL tho
    3287   REAL ptimestep, l_mix, r_aspect
    3288   REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
    3289   REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
    3290   REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
    3291   REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
    3292   REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1)
    3293   REAL pphi(ngrid, nlay)
    3294 
    3295   INTEGER idetr
    3296   SAVE idetr
    3297   DATA idetr/3/
    3298   !$OMP THREADPRIVATE(idetr)
    3299 
    3300   ! local:
    3301   ! ------
    3302 
    3303   INTEGER ig, k, l, lmaxa(klon), lmix(klon)
    3304   REAL zsortie1d(klon)
    3305   ! CR: on remplace lmax(klon,klev+1)
    3306   INTEGER lmax(klon), lmin(klon), lentr(klon)
    3307   REAL linter(klon)
    3308   REAL zmix(klon), fracazmix(klon)
    3309   ! RC
    3310   REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz
    3311 
    3312   REAL zlev(klon, klev+1), zlay(klon, klev)
    3313   REAL zh(klon, klev), zdhadj(klon, klev)
    3314   REAL ztv(klon, klev)
    3315   REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
    3316   REAL wh(klon, klev+1)
    3317   REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1)
    3318   REAL zla(klon, klev+1)
    3319   REAL zwa(klon, klev+1)
    3320   REAL zld(klon, klev+1)
    3321   REAL zwd(klon, klev+1)
    3322   REAL zsortie(klon, klev)
    3323   REAL zva(klon, klev)
    3324   REAL zua(klon, klev)
    3325   REAL zoa(klon, klev)
    3326 
    3327   REAL zha(klon, klev)
    3328   REAL wa_moy(klon, klev+1)
    3329   REAL fraca(klon, klev+1)
    3330   REAL fracc(klon, klev+1)
    3331   REAL zf, zf2
    3332   REAL thetath2(klon, klev), wth2(klon, klev)
    3333   ! common/comtherm/thetath2,wth2
    3334 
    3335   REAL count_time
    3336   INTEGER ialt
    3337 
    3338   LOGICAL sorties
    3339   REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev)
    3340   REAL zpspsk(klon, klev)
    3341 
    3342   ! real wmax(klon,klev),wmaxa(klon)
    3343   REAL wmax(klon), wmaxa(klon)
    3344   REAL wa(klon, klev, klev+1)
    3345   REAL wd(klon, klev+1)
    3346   REAL larg_part(klon, klev, klev+1)
    3347   REAL fracd(klon, klev+1)
    3348   REAL xxx(klon, klev+1)
    3349   REAL larg_cons(klon, klev+1)
    3350   REAL larg_detr(klon, klev+1)
    3351   REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev)
    3352   REAL pu_therm(klon, klev), pv_therm(klon, klev)
    3353   REAL fm(klon, klev+1), entr(klon, klev)
    3354   REAL fmc(klon, klev+1)
    3355 
    3356   ! CR:nouvelles variables
    3357   REAL f_star(klon, klev+1), entr_star(klon, klev)
    3358   REAL entr_star_tot(klon), entr_star2(klon)
    3359   REAL f(klon), f0(klon)
    3360   REAL zlevinter(klon)
    3361   LOGICAL first
    3362   DATA first/.FALSE./
    3363   SAVE first
    3364   !$OMP THREADPRIVATE(first)
    3365   ! RC
    3366 
    3367   CHARACTER *2 str2
    3368   CHARACTER *10 str10
    3369 
    3370   CHARACTER (LEN=20) :: modname = 'thermcell'
    3371   CHARACTER (LEN=80) :: abort_message
    3372 
    3373   LOGICAL vtest(klon), down
    3374 
    3375   EXTERNAL scopy
    3376 
    3377   INTEGER ncorrec, ll
    3378   SAVE ncorrec
    3379   DATA ncorrec/0/
    3380   !$OMP THREADPRIVATE(ncorrec)
    3381 
    3382 
    3383   ! -----------------------------------------------------------------------
    3384   ! initialisation:
    3385   ! ---------------
    3386 
    3387   sorties = .TRUE.
    3388   IF (ngrid/=klon) THEN
    3389     PRINT *
    3390     PRINT *, 'STOP dans convadj'
    3391     PRINT *, 'ngrid    =', ngrid
    3392     PRINT *, 'klon  =', klon
    3393   END IF
    3394 
    3395   ! -----------------------------------------------------------------------
    3396   ! incrementation eventuelle de tendances precedentes:
    3397   ! ---------------------------------------------------
    3398 
    3399   ! PRINT*,'0 OK convect8'
    3400 
    3401   DO l = 1, nlay
    3402     DO ig = 1, ngrid
    3403       zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa
    3404       zh(ig, l) = pt(ig, l)/zpspsk(ig, l)
    3405       zu(ig, l) = pu(ig, l)
    3406       zv(ig, l) = pv(ig, l)
    3407       zo(ig, l) = po(ig, l)
    3408       ztv(ig, l) = zh(ig, l)*(1.+0.61*zo(ig,l))
    3409     END DO
    3410   END DO
    3411 
    3412   ! PRINT*,'1 OK convect8'
    3413   ! --------------------
    3414 
    3415 
    3416   ! + + + + + + + + + + +
    3417 
    3418 
    3419   ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
    3420   ! wh,wt,wo ...
    3421 
    3422   ! + + + + + + + + + + +  zh,zu,zv,zo,rho
    3423 
    3424 
    3425   ! --------------------   zlev(1)
    3426   ! \\\\\\\\\\\\\\\\\\\\
    3427 
    3428 
    3429 
    3430   ! -----------------------------------------------------------------------
    3431   ! Calcul des altitudes des couches
    3432   ! -----------------------------------------------------------------------
    3433 
    3434   DO l = 2, nlay
    3435     DO ig = 1, ngrid
    3436       zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg
    3437     END DO
    3438   END DO
    3439   DO ig = 1, ngrid
    3440     zlev(ig, 1) = 0.
    3441     zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg
    3442   END DO
    3443   DO l = 1, nlay
    3444     DO ig = 1, ngrid
    3445       zlay(ig, l) = pphi(ig, l)/rg
    3446     END DO
    3447   END DO
    3448 
    3449   ! PRINT*,'2 OK convect8'
    3450   ! -----------------------------------------------------------------------
    3451   ! Calcul des densites
    3452   ! -----------------------------------------------------------------------
    3453 
    3454   DO l = 1, nlay
    3455     DO ig = 1, ngrid
    3456       rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*zh(ig,l))
    3457     END DO
    3458   END DO
    3459 
    3460   DO l = 2, nlay
    3461     DO ig = 1, ngrid
    3462       rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1))
    3463     END DO
    3464   END DO
    3465 
    3466   DO k = 1, nlay
    3467     DO l = 1, nlay + 1
    3468       DO ig = 1, ngrid
    3469         wa(ig, k, l) = 0.
    3470       END DO
    3471     END DO
    3472   END DO
    3473 
    3474   ! PRINT*,'3 OK convect8'
    3475   ! ------------------------------------------------------------------
    3476   ! Calcul de w2, quarre de w a partir de la cape
    3477   ! a partir de w2, on calcule wa, vitesse de l'ascendance
    3478 
    3479   ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
    3480   ! w2 est stoke dans wa
    3481 
    3482   ! ATTENTION: dans convect8, on n'utilise le calcule des wa
    3483   ! independants par couches que pour calculer l'entrainement
    3484   ! a la base et la hauteur max de l'ascendance.
    3485 
    3486   ! Indicages:
    3487   ! l'ascendance provenant du niveau k traverse l'interface l avec
    3488   ! une vitesse wa(k,l).
    3489 
    3490   ! --------------------
    3491 
    3492   ! + + + + + + + + + +
    3493 
    3494   ! wa(k,l)   ----       --------------------    l
    3495   ! /\
    3496   ! /||\       + + + + + + + + + +
    3497   ! ||
    3498   ! ||        --------------------
    3499   ! ||
    3500   ! ||        + + + + + + + + + +
    3501   ! ||
    3502   ! ||        --------------------
    3503   ! ||__
    3504   ! |___      + + + + + + + + + +     k
    3505 
    3506   ! --------------------
    3507 
    3508 
    3509 
    3510   ! ------------------------------------------------------------------
    3511 
    3512   ! CR: ponderation entrainement des couches instables
    3513   ! def des entr_star tels que entr=f*entr_star
    3514   DO l = 1, klev
    3515     DO ig = 1, ngrid
    3516       entr_star(ig, l) = 0.
    3517     END DO
    3518   END DO
    3519   ! determination de la longueur de la couche d entrainement
    3520   DO ig = 1, ngrid
    3521     lentr(ig) = 1
    3522   END DO
    3523 
    3524   ! on ne considere que les premieres couches instables
    3525   DO k = nlay - 2, 1, -1
    3526     DO ig = 1, ngrid
    3527       IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN
    3528         lentr(ig) = k
    3529       END IF
    3530     END DO
    3531   END DO
    3532 
    3533   ! determination du lmin: couche d ou provient le thermique
    3534   DO ig = 1, ngrid
    3535     lmin(ig) = 1
    3536   END DO
    3537   DO ig = 1, ngrid
    3538     DO l = nlay, 2, -1
    3539       IF (ztv(ig,l-1)>ztv(ig,l)) THEN
    3540         lmin(ig) = l - 1
    3541       END IF
    3542     END DO
    3543   END DO
    3544 
    3545   ! definition de l'entrainement des couches
    3546   DO l = 1, klev - 1
    3547     DO ig = 1, ngrid
    3548       IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN
    3549         entr_star(ig, l) = (ztv(ig,l)-ztv(ig,l+1))*(zlev(ig,l+1)-zlev(ig,l))
    3550       END IF
    3551     END DO
    3552   END DO
    3553   ! pas de thermique si couches 1->5 stables
    3554   DO ig = 1, ngrid
    3555     IF (lmin(ig)>5) THEN
    3556       DO l = 1, klev
    3557         entr_star(ig, l) = 0.
    3558       END DO
    3559     END IF
    3560   END DO
    3561   ! calcul de l entrainement total
    3562   DO ig = 1, ngrid
    3563     entr_star_tot(ig) = 0.
    3564   END DO
    3565   DO ig = 1, ngrid
    3566     DO k = 1, klev
    3567       entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k)
    3568     END DO
    3569   END DO
    3570 
    3571   PRINT *, 'fin calcul entr_star'
    3572   DO k = 1, klev
    3573     DO ig = 1, ngrid
    3574       ztva(ig, k) = ztv(ig, k)
    3575     END DO
    3576   END DO
    3577   ! RC
    3578   ! PRINT*,'7 OK convect8'
    3579   DO k = 1, klev + 1
    3580     DO ig = 1, ngrid
    3581       zw2(ig, k) = 0.
    3582       fmc(ig, k) = 0.
    3583       ! CR
    3584       f_star(ig, k) = 0.
    3585       ! RC
    3586       larg_cons(ig, k) = 0.
    3587       larg_detr(ig, k) = 0.
    3588       wa_moy(ig, k) = 0.
    3589     END DO
    3590   END DO
    3591 
    3592   ! PRINT*,'8 OK convect8'
    3593   DO ig = 1, ngrid
    3594     linter(ig) = 1.
    3595     lmaxa(ig) = 1
    3596     lmix(ig) = 1
    3597     wmaxa(ig) = 0.
    3598   END DO
    3599 
    3600   ! CR:
    3601   DO l = 1, nlay - 2
    3602     DO ig = 1, ngrid
    3603       IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. &
    3604           zw2(ig,l)<1E-10) THEN
    3605         f_star(ig, l+1) = entr_star(ig, l)
    3606         ! test:calcul de dteta
    3607         zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* &
    3608           (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l))
    3609         larg_detr(ig, l) = 0.
    3610       ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, &
    3611           l)>1.E-10)) THEN
    3612         f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l)
    3613         ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)*ztv(ig,l))/ &
    3614           f_star(ig, l+1)
    3615         zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + &
    3616           2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l))
    3617       END IF
    3618       ! determination de zmax continu par interpolation lineaire
    3619       IF (zw2(ig,l+1)<0.) THEN
    3620         ! test
    3621         IF (abs(zw2(ig,l+1)-zw2(ig,l))<1E-10) THEN
    3622           PRINT *, 'pb linter'
    3623         END IF
    3624         linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( &
    3625           ig,l))
    3626         zw2(ig, l+1) = 0.
    3627         lmaxa(ig) = l
    3628       ELSE
    3629         IF (zw2(ig,l+1)<0.) THEN
    3630           PRINT *, 'pb1 zw2<0'
    3631         END IF
    3632         wa_moy(ig, l+1) = sqrt(zw2(ig,l+1))
    3633       END IF
    3634       IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN
    3635         ! lmix est le niveau de la couche ou w (wa_moy) est maximum
    3636         lmix(ig) = l + 1
    3637         wmaxa(ig) = wa_moy(ig, l+1)
    3638       END IF
    3639     END DO
    3640   END DO
    3641   PRINT *, 'fin calcul zw2'
    3642 
    3643   ! Calcul de la couche correspondant a la hauteur du thermique
    3644   DO ig = 1, ngrid
    3645     lmax(ig) = lentr(ig)
    3646   END DO
    3647   DO ig = 1, ngrid
    3648     DO l = nlay, lentr(ig) + 1, -1
    3649       IF (zw2(ig,l)<=1.E-10) THEN
    3650         lmax(ig) = l - 1
    3651       END IF
    3652     END DO
    3653   END DO
    3654   ! pas de thermique si couches 1->5 stables
    3655   DO ig = 1, ngrid
    3656     IF (lmin(ig)>5) THEN
    3657       lmax(ig) = 1
    3658       lmin(ig) = 1
    3659     END IF
    3660   END DO
    3661 
    3662   ! Determination de zw2 max
    3663   DO ig = 1, ngrid
    3664     wmax(ig) = 0.
    3665   END DO
    3666 
    3667   DO l = 1, nlay
    3668     DO ig = 1, ngrid
    3669       IF (l<=lmax(ig)) THEN
    3670         IF (zw2(ig,l)<0.) THEN
    3671           PRINT *, 'pb2 zw2<0'
    3672         END IF
    3673         zw2(ig, l) = sqrt(zw2(ig,l))
    3674         wmax(ig) = max(wmax(ig), zw2(ig,l))
    3675       ELSE
    3676         zw2(ig, l) = 0.
    3677       END IF
    3678     END DO
    3679   END DO
    3680 
    3681   ! Longueur caracteristique correspondant a la hauteur des thermiques.
    3682   DO ig = 1, ngrid
    3683     zmax(ig) = 0.
    3684     zlevinter(ig) = zlev(ig, 1)
    3685   END DO
    3686   DO ig = 1, ngrid
    3687     ! calcul de zlevinter
    3688     zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + &
    3689       zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
    3690     zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig)))
    3691   END DO
    3692 
    3693   PRINT *, 'avant fermeture'
    3694   ! Fermeture,determination de f
    3695   DO ig = 1, ngrid
    3696     entr_star2(ig) = 0.
    3697   END DO
    3698   DO ig = 1, ngrid
    3699     IF (entr_star_tot(ig)<1.E-10) THEN
    3700       f(ig) = 0.
    3701     ELSE
    3702       DO k = lmin(ig), lentr(ig)
    3703         entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( &
    3704           zlev(ig,k+1)-zlev(ig,k)))
    3705       END DO
    3706       ! Nouvelle fermeture
    3707       f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*entr_star2(ig))* &
    3708         entr_star_tot(ig)
    3709       ! test
    3710       ! if (first) THEN
    3711       ! f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
    3712       ! s             *wmax(ig))
    3713       ! END IF
    3714     END IF
    3715     ! f0(ig)=f(ig)
    3716     ! first=.TRUE.
    3717   END DO
    3718   PRINT *, 'apres fermeture'
    3719 
    3720   ! Calcul de l'entrainement
    3721   DO k = 1, klev
    3722     DO ig = 1, ngrid
    3723       entr(ig, k) = f(ig)*entr_star(ig, k)
    3724     END DO
    3725   END DO
    3726   ! Calcul des flux
    3727   DO ig = 1, ngrid
    3728     DO l = 1, lmax(ig) - 1
    3729       fmc(ig, l+1) = fmc(ig, l) + entr(ig, l)
    3730     END DO
    3731   END DO
    3732 
    3733   ! RC
    3734 
    3735 
    3736   ! PRINT*,'9 OK convect8'
    3737   ! PRINT*,'WA1 ',wa_moy
    3738 
    3739   ! determination de l'indice du debut de la mixed layer ou w decroit
    3740 
    3741   ! calcul de la largeur de chaque ascendance dans le cas conservatif.
    3742   ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
    3743   ! d'une couche est égale à la hauteur de la couche alimentante.
    3744   ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
    3745   ! de la vitesse d'entrainement horizontal dans la couche alimentante.
    3746 
    3747   DO l = 2, nlay
    3748     DO ig = 1, ngrid
    3749       IF (l<=lmaxa(ig)) THEN
    3750         zw = max(wa_moy(ig,l), 1.E-10)
    3751         larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw)
    3752       END IF
    3753     END DO
    3754   END DO
    3755 
    3756   DO l = 2, nlay
    3757     DO ig = 1, ngrid
    3758       IF (l<=lmaxa(ig)) THEN
    3759         ! if (idetr.EQ.0) THEN
    3760         ! cette option est finalement en dur.
    3761         IF ((l_mix*zlev(ig,l))<0.) THEN
    3762           PRINT *, 'pb l_mix*zlev<0'
    3763         END IF
    3764         larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l))
    3765         ! ELSE IF (idetr.EQ.1) THEN
    3766         ! larg_detr(ig,l)=larg_cons(ig,l)
    3767         ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
    3768         ! ELSE IF (idetr.EQ.2) THEN
    3769         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    3770         ! s            *sqrt(wa_moy(ig,l))
    3771         ! ELSE IF (idetr.EQ.4) THEN
    3772         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    3773         ! s            *wa_moy(ig,l)
    3774         ! END IF
    3775       END IF
    3776     END DO
    3777   END DO
    3778 
    3779   ! PRINT*,'10 OK convect8'
    3780   ! PRINT*,'WA2 ',wa_moy
    3781   ! calcul de la fraction de la maille concernée par l'ascendance en tenant
    3782   ! compte de l'epluchage du thermique.
    3783 
    3784   ! CR def de  zmix continu (profil parabolique des vitesses)
    3785   DO ig = 1, ngrid
    3786     IF (lmix(ig)>1.) THEN
    3787       ! test
    3788       IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- &
    3789           (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- &
    3790           zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- &
    3791           (zlev(ig,lmix(ig)))))>1E-10) THEN
    3792 
    3793         zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) &
    3794           )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, &
    3795           lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ &
    3796           (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- &
    3797           (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- &
    3798           zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
    3799       ELSE
    3800         zmix(ig) = zlev(ig, lmix(ig))
    3801         PRINT *, 'pb zmix'
    3802       END IF
    3803     ELSE
    3804       zmix(ig) = 0.
    3805     END IF
    3806     ! test
    3807     IF ((zmax(ig)-zmix(ig))<0.) THEN
    3808       zmix(ig) = 0.99*zmax(ig)
    3809       ! PRINT*,'pb zmix>zmax'
    3810     END IF
    3811   END DO
    3812 
    3813   ! calcul du nouveau lmix correspondant
    3814   DO ig = 1, ngrid
    3815     DO l = 1, klev
    3816       IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)<zlev(ig,l+1)) THEN
    3817         lmix(ig) = l
    3818       END IF
    3819     END DO
    3820   END DO
    3821 
    3822   DO l = 2, nlay
    3823     DO ig = 1, ngrid
    3824       IF (larg_cons(ig,l)>1.) THEN
    3825         ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
    3826         fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig))
    3827         ! test
    3828         fraca(ig, l) = max(fraca(ig,l), 0.)
    3829         fraca(ig, l) = min(fraca(ig,l), 0.5)
    3830         fracd(ig, l) = 1. - fraca(ig, l)
    3831         fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig))
    3832       ELSE
    3833         ! wa_moy(ig,l)=0.
    3834         fraca(ig, l) = 0.
    3835         fracc(ig, l) = 0.
    3836         fracd(ig, l) = 1.
    3837       END IF
    3838     END DO
    3839   END DO
    3840   ! CR: calcul de fracazmix
    3841   DO ig = 1, ngrid
    3842     fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ &
    3843       (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + &
    3844       fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig &
    3845       ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
    3846   END DO
    3847 
    3848   DO l = 2, nlay
    3849     DO ig = 1, ngrid
    3850       IF (larg_cons(ig,l)>1.) THEN
    3851         IF (l>lmix(ig)) THEN
    3852           ! test
    3853           IF (zmax(ig)-zmix(ig)<1.E-10) THEN
    3854             ! PRINT*,'pb xxx'
    3855             xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
    3856           ELSE
    3857             xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
    3858           END IF
    3859           IF (idetr==0) THEN
    3860             fraca(ig, l) = fracazmix(ig)
    3861           ELSE IF (idetr==1) THEN
    3862             fraca(ig, l) = fracazmix(ig)*xxx(ig, l)
    3863           ELSE IF (idetr==2) THEN
    3864             fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
    3865           ELSE
    3866             fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2
    3867           END IF
    3868           ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
    3869           fraca(ig, l) = max(fraca(ig,l), 0.)
    3870           fraca(ig, l) = min(fraca(ig,l), 0.5)
    3871           fracd(ig, l) = 1. - fraca(ig, l)
    3872           fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig))
    3873         END IF
    3874       END IF
    3875     END DO
    3876   END DO
    3877 
    3878   PRINT *, 'fin calcul fraca'
    3879   ! PRINT*,'11 OK convect8'
    3880   ! PRINT*,'Ea3 ',wa_moy
    3881   ! ------------------------------------------------------------------
    3882   ! Calcul de fracd, wd
    3883   ! somme wa - wd = 0
    3884   ! ------------------------------------------------------------------
    3885 
    3886 
    3887   DO ig = 1, ngrid
    3888     fm(ig, 1) = 0.
    3889     fm(ig, nlay+1) = 0.
    3890   END DO
    3891 
    3892   DO l = 2, nlay
    3893     DO ig = 1, ngrid
    3894       fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l)
    3895       ! CR:test
    3896       IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN
    3897         fm(ig, l) = fm(ig, l-1)
    3898         ! WRITE(1,*)'ajustement fm, l',l
    3899       END IF
    3900       ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
    3901       ! RC
    3902     END DO
    3903     DO ig = 1, ngrid
    3904       IF (fracd(ig,l)<0.1) THEN
    3905         abort_message = 'fracd trop petit'
    3906         CALL abort_physic(modname, abort_message, 1)
    3907       ELSE
    3908         ! vitesse descendante "diagnostique"
    3909         wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l))
    3910       END IF
    3911     END DO
    3912   END DO
    3913 
    3914   DO l = 1, nlay
    3915     DO ig = 1, ngrid
    3916       ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    3917       masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg
    3918     END DO
    3919   END DO
    3920 
    3921   ! PRINT*,'12 OK convect8'
    3922   ! PRINT*,'WA4 ',wa_moy
    3923   ! c------------------------------------------------------------------
    3924   ! calcul du transport vertical
    3925   ! ------------------------------------------------------------------
    3926 
    3927   GO TO 4444
    3928   ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
    3929   DO l = 2, nlay - 1
    3930     DO ig = 1, ngrid
    3931       IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( &
    3932           ig,l+1)) THEN
    3933         ! PRINT*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
    3934         ! s         ,fm(ig,l+1)*ptimestep
    3935         ! s         ,'   M=',masse(ig,l),masse(ig,l+1)
    3936       END IF
    3937     END DO
    3938   END DO
    3939 
    3940   DO l = 1, nlay
    3941     DO ig = 1, ngrid
    3942       IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN
    3943         ! PRINT*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
    3944         ! s         ,entr(ig,l)*ptimestep
    3945         ! s         ,'   M=',masse(ig,l)
    3946       END IF
    3947     END DO
    3948   END DO
    3949 
    3950   DO l = 1, nlay
    3951     DO ig = 1, ngrid
    3952       IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN
    3953         ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
    3954         ! s         ,'   FM=',fm(ig,l)
    3955       END IF
    3956       IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN
    3957         ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
    3958         ! s         ,'   M=',masse(ig,l)
    3959         ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
    3960         ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
    3961         ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
    3962         ! s                ,zlev(ig,l+1),zlev(ig,l)
    3963         ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
    3964         ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
    3965       END IF
    3966       IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN
    3967         ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
    3968         ! s         ,'   E=',entr(ig,l)
    3969       END IF
    3970     END DO
    3971   END DO
    3972 
    3973 4444 CONTINUE
    3974 
    3975   ! CR:redefinition du entr
    3976   DO l = 1, nlay
    3977     DO ig = 1, ngrid
    3978       detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1)
    3979       IF (detr(ig,l)<0.) THEN
    3980         entr(ig, l) = entr(ig, l) - detr(ig, l)
    3981         detr(ig, l) = 0.
    3982         ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
    3983       END IF
    3984     END DO
    3985   END DO
    3986   ! RC
    3987   IF (w2di==1) THEN
    3988     fm0 = fm0 + ptimestep*(fm-fm0)/tho
    3989     entr0 = entr0 + ptimestep*(entr-entr0)/tho
    3990   ELSE
    3991     fm0 = fm
    3992     entr0 = entr
    3993   END IF
    3994 
    3995   IF (1==1) THEN
    3996     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, &
    3997       zha)
    3998     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, &
    3999       zoa)
    4000   ELSE
    4001     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
    4002       zdhadj, zha)
    4003     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
    4004       pdoadj, zoa)
    4005   END IF
    4006 
    4007   IF (1==0) THEN
    4008     CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
    4009       zu, zv, pduadj, pdvadj, zua, zva)
    4010   ELSE
    4011     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
    4012       zua)
    4013     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
    4014       zva)
    4015   END IF
    4016 
    4017   DO l = 1, nlay
    4018     DO ig = 1, ngrid
    4019       zf = 0.5*(fracc(ig,l)+fracc(ig,l+1))
    4020       zf2 = zf/(1.-zf)
    4021       thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2
    4022       wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
    4023     END DO
    4024   END DO
    4025 
    4026 
    4027 
    4028   ! PRINT*,'13 OK convect8'
    4029   ! PRINT*,'WA5 ',wa_moy
    4030   DO l = 1, nlay
    4031     DO ig = 1, ngrid
    4032       pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l)
    4033     END DO
    4034   END DO
    4035 
    4036 
    4037   ! do l=1,nlay
    4038   ! do ig=1,ngrid
    4039   ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
    4040   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    4041   ! s         ,'   pdtadj=',pdtadj(ig,l)
    4042   ! END IF
    4043   ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
    4044   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    4045   ! s         ,'   pdoadj=',pdoadj(ig,l)
    4046   ! END IF
    4047   ! enddo
    4048   ! enddo
    4049 
    4050   ! PRINT*,'14 OK convect8'
    4051   ! ------------------------------------------------------------------
    4052   ! Calculs pour les sorties
    4053   ! ------------------------------------------------------------------
    4054 
    4055   IF (sorties) THEN
    4056     DO l = 1, nlay
    4057       DO ig = 1, ngrid
    4058         zla(ig, l) = (1.-fracd(ig,l))*zmax(ig)
    4059         zld(ig, l) = fracd(ig, l)*zmax(ig)
    4060         IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ &
    4061           (1.-fracd(ig,l))
    4062       END DO
    4063     END DO
    4064 
    4065     ! deja fait
     4015        pdtadj(ig, l) = zdhadj(ig, l) * zpspsk(ig, l)
     4016      END DO
     4017    END DO
     4018
     4019
    40664020    ! do l=1,nlay
    40674021    ! do ig=1,ngrid
    4068     ! detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
    4069     ! if (detr(ig,l).lt.0.) THEN
    4070     ! entr(ig,l)=entr(ig,l)-detr(ig,l)
    4071     ! detr(ig,l)=0.
    4072     ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
     4022    ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
     4023    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     4024    ! s         ,'   pdtadj=',pdtadj(ig,l)
     4025    ! END IF
     4026    ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
     4027    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     4028    ! s         ,'   pdoadj=',pdoadj(ig,l)
    40734029    ! END IF
    40744030    ! enddo
    40754031    ! enddo
    40764032
    4077     ! PRINT*,'15 OK convect8'
    4078 
    4079 
    4080     ! #define und
    4081     GO TO 123
     4033    ! PRINT*,'14 OK convect8'
     4034    ! ------------------------------------------------------------------
     4035    ! Calculs pour les sorties
     4036    ! ------------------------------------------------------------------
     4037
     4038    IF (sorties) THEN
     4039      DO l = 1, nlay
     4040        DO ig = 1, ngrid
     4041          zla(ig, l) = (1. - fracd(ig, l)) * zmax(ig)
     4042          zld(ig, l) = fracd(ig, l) * zmax(ig)
     4043          IF (1. - fracd(ig, l)>1.E-10) zwa(ig, l) = wd(ig, l) * fracd(ig, l) / &
     4044                  (1. - fracd(ig, l))
     4045        END DO
     4046      END DO
     4047
     4048      ! deja fait
     4049      ! do l=1,nlay
     4050      ! do ig=1,ngrid
     4051      ! detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
     4052      ! if (detr(ig,l).lt.0.) THEN
     4053      ! entr(ig,l)=entr(ig,l)-detr(ig,l)
     4054      ! detr(ig,l)=0.
     4055      ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
     4056      ! END IF
     4057      ! enddo
     4058      ! enddo
     4059
     4060      ! PRINT*,'15 OK convect8'
     4061
     4062
     4063      ! #define und
     4064      GO TO 123
    40824065#ifdef und
    40834066    CALL writeg1d(1, nlay, wd, 'wd      ', 'wd      ')
    … …  
    41154098    CALL writeg1d(1, nlay, wh, 'wh2     ', 'wh2     ')
    41164099#endif
    4117 123 CONTINUE
    4118 
    4119   END IF
    4120 
    4121   ! IF(wa_moy(1,4).gt.1.e-10) stop
    4122 
    4123   ! PRINT*,'19 OK convect8'
    4124 
    4125 END SUBROUTINE thermcell
    4126 
    4127 SUBROUTINE dqthermcell(ngrid, nlay, ptimestep, fm, entr, masse, q, dq, qa)
    4128   USE dimphy
    4129   IMPLICIT NONE
    4130 
    4131   ! =======================================================================
    4132 
    4133   ! Calcul du transport verticale dans la couche limite en presence
    4134   ! de "thermiques" explicitement representes
    4135   ! calcul du dq/dt une fois qu'on connait les ascendances
    4136 
    4137   ! =======================================================================
    4138 
    4139   INTEGER ngrid, nlay
    4140 
    4141   REAL ptimestep
    4142   REAL masse(ngrid, nlay), fm(ngrid, nlay+1)
    4143   REAL entr(ngrid, nlay)
    4144   REAL q(ngrid, nlay)
    4145   REAL dq(ngrid, nlay)
    4146 
    4147   REAL qa(klon, klev), detr(klon, klev), wqd(klon, klev+1)
    4148 
    4149   INTEGER ig, k
    4150 
    4151   ! calcul du detrainement
    4152 
    4153   DO k = 1, nlay
    4154     DO ig = 1, ngrid
    4155       detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k)
    4156       ! test
    4157       IF (detr(ig,k)<0.) THEN
    4158         entr(ig, k) = entr(ig, k) - detr(ig, k)
    4159         detr(ig, k) = 0.
    4160         ! PRINT*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k),
    4161         ! s         'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k)
     4100      123 CONTINUE
     4101
     4102    END IF
     4103
     4104    ! IF(wa_moy(1,4).gt.1.e-10) stop
     4105
     4106    ! PRINT*,'19 OK convect8'
     4107
     4108  END SUBROUTINE thermcell
     4109
     4110  SUBROUTINE dqthermcell(ngrid, nlay, ptimestep, fm, entr, masse, q, dq, qa)
     4111    USE dimphy
     4112    IMPLICIT NONE
     4113
     4114    ! =======================================================================
     4115
     4116    ! Calcul du transport verticale dans la couche limite en presence
     4117    ! de "thermiques" explicitement representes
     4118    ! calcul du dq/dt une fois qu'on connait les ascendances
     4119
     4120    ! =======================================================================
     4121
     4122    INTEGER ngrid, nlay
     4123
     4124    REAL ptimestep
     4125    REAL masse(ngrid, nlay), fm(ngrid, nlay + 1)
     4126    REAL entr(ngrid, nlay)
     4127    REAL q(ngrid, nlay)
     4128    REAL dq(ngrid, nlay)
     4129
     4130    REAL qa(klon, klev), detr(klon, klev), wqd(klon, klev + 1)
     4131
     4132    INTEGER ig, k
     4133
     4134    ! calcul du detrainement
     4135
     4136    DO k = 1, nlay
     4137      DO ig = 1, ngrid
     4138        detr(ig, k) = fm(ig, k) - fm(ig, k + 1) + entr(ig, k)
     4139        ! test
     4140        IF (detr(ig, k)<0.) THEN
     4141          entr(ig, k) = entr(ig, k) - detr(ig, k)
     4142          detr(ig, k) = 0.
     4143          ! PRINT*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k),
     4144          ! s         'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k)
     4145        END IF
     4146        IF (fm(ig, k + 1)<0.) THEN
     4147          ! PRINT*,'fm2<0!!!'
     4148        END IF
     4149        IF (entr(ig, k)<0.) THEN
     4150          ! PRINT*,'entr2<0!!!'
     4151        END IF
     4152      END DO
     4153    END DO
     4154
     4155    ! calcul de la valeur dans les ascendances
     4156    DO ig = 1, ngrid
     4157      qa(ig, 1) = q(ig, 1)
     4158    END DO
     4159
     4160    DO k = 2, nlay
     4161      DO ig = 1, ngrid
     4162        IF ((fm(ig, k + 1) + detr(ig, k)) * ptimestep>1.E-5 * masse(ig, k)) THEN
     4163          qa(ig, k) = (fm(ig, k) * qa(ig, k - 1) + entr(ig, k) * q(ig, k)) / &
     4164                  (fm(ig, k + 1) + detr(ig, k))
     4165        ELSE
     4166          qa(ig, k) = q(ig, k)
     4167        END IF
     4168        IF (qa(ig, k)<0.) THEN
     4169          ! PRINT*,'qa<0!!!'
     4170        END IF
     4171        IF (q(ig, k)<0.) THEN
     4172          ! PRINT*,'q<0!!!'
     4173        END IF
     4174      END DO
     4175    END DO
     4176
     4177    DO k = 2, nlay
     4178      DO ig = 1, ngrid
     4179        ! wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
     4180        wqd(ig, k) = fm(ig, k) * q(ig, k)
     4181        IF (wqd(ig, k)<0.) THEN
     4182          ! PRINT*,'wqd<0!!!'
     4183        END IF
     4184      END DO
     4185    END DO
     4186    DO ig = 1, ngrid
     4187      wqd(ig, 1) = 0.
     4188      wqd(ig, nlay + 1) = 0.
     4189    END DO
     4190
     4191    DO k = 1, nlay
     4192      DO ig = 1, ngrid
     4193        dq(ig, k) = (detr(ig, k) * qa(ig, k) - entr(ig, k) * q(ig, k) - wqd(ig, k) + wqd(ig, k + &
     4194                1)) / masse(ig, k)
     4195        ! if (dq(ig,k).lt.0.) THEN
     4196        ! PRINT*,'dq<0!!!'
     4197        ! END IF
     4198      END DO
     4199    END DO
     4200
     4201  END SUBROUTINE dqthermcell
     4202  SUBROUTINE dvthermcell(ngrid, nlay, ptimestep, fm, entr, masse, fraca, larga, &
     4203          u, v, du, dv, ua, va)
     4204    USE dimphy
     4205    IMPLICIT NONE
     4206
     4207    ! =======================================================================
     4208
     4209    ! Calcul du transport verticale dans la couche limite en presence
     4210    ! de "thermiques" explicitement representes
     4211    ! calcul du dq/dt une fois qu'on connait les ascendances
     4212
     4213    ! =======================================================================
     4214
     4215    INTEGER ngrid, nlay
     4216
     4217    REAL ptimestep
     4218    REAL masse(ngrid, nlay), fm(ngrid, nlay + 1)
     4219    REAL fraca(ngrid, nlay + 1)
     4220    REAL larga(ngrid)
     4221    REAL entr(ngrid, nlay)
     4222    REAL u(ngrid, nlay)
     4223    REAL ua(ngrid, nlay)
     4224    REAL du(ngrid, nlay)
     4225    REAL v(ngrid, nlay)
     4226    REAL va(ngrid, nlay)
     4227    REAL dv(ngrid, nlay)
     4228
     4229    REAL qa(klon, klev), detr(klon, klev)
     4230    REAL wvd(klon, klev + 1), wud(klon, klev + 1)
     4231    REAL gamma0, gamma(klon, klev + 1)
     4232    REAL dua, dva
     4233    INTEGER iter
     4234
     4235    INTEGER ig, k
     4236
     4237    ! calcul du detrainement
     4238
     4239    DO k = 1, nlay
     4240      DO ig = 1, ngrid
     4241        detr(ig, k) = fm(ig, k) - fm(ig, k + 1) + entr(ig, k)
     4242      END DO
     4243    END DO
     4244
     4245    ! calcul de la valeur dans les ascendances
     4246    DO ig = 1, ngrid
     4247      ua(ig, 1) = u(ig, 1)
     4248      va(ig, 1) = v(ig, 1)
     4249    END DO
     4250
     4251    DO k = 2, nlay
     4252      DO ig = 1, ngrid
     4253        IF ((fm(ig, k + 1) + detr(ig, k)) * ptimestep>1.E-5 * masse(ig, k)) THEN
     4254          ! On itère sur la valeur du coeff de freinage.
     4255          ! gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
     4256          gamma0 = masse(ig, k) * sqrt(0.5 * (fraca(ig, k + 1) + fraca(ig, &
     4257                  k))) * 0.5 / larga(ig)
     4258          ! gamma0=0.
     4259          ! la première fois on multiplie le coefficient de freinage
     4260          ! par le module du vent dans la couche en dessous.
     4261          dua = ua(ig, k - 1) - u(ig, k - 1)
     4262          dva = va(ig, k - 1) - v(ig, k - 1)
     4263          DO iter = 1, 5
     4264            gamma(ig, k) = gamma0 * sqrt(dua**2 + dva**2)
     4265            ua(ig, k) = (fm(ig, k) * ua(ig, k - 1) + (entr(ig, k) + gamma(ig, &
     4266                    k)) * u(ig, k)) / (fm(ig, k + 1) + detr(ig, k) + gamma(ig, k))
     4267            va(ig, k) = (fm(ig, k) * va(ig, k - 1) + (entr(ig, k) + gamma(ig, &
     4268                    k)) * v(ig, k)) / (fm(ig, k + 1) + detr(ig, k) + gamma(ig, k))
     4269            ! PRINT*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
     4270            dua = ua(ig, k) - u(ig, k)
     4271            dva = va(ig, k) - v(ig, k)
     4272          END DO
     4273        ELSE
     4274          ua(ig, k) = u(ig, k)
     4275          va(ig, k) = v(ig, k)
     4276          gamma(ig, k) = 0.
     4277        END IF
     4278      END DO
     4279    END DO
     4280
     4281    DO k = 2, nlay
     4282      DO ig = 1, ngrid
     4283        wud(ig, k) = fm(ig, k) * u(ig, k)
     4284        wvd(ig, k) = fm(ig, k) * v(ig, k)
     4285      END DO
     4286    END DO
     4287    DO ig = 1, ngrid
     4288      wud(ig, 1) = 0.
     4289      wud(ig, nlay + 1) = 0.
     4290      wvd(ig, 1) = 0.
     4291      wvd(ig, nlay + 1) = 0.
     4292    END DO
     4293
     4294    DO k = 1, nlay
     4295      DO ig = 1, ngrid
     4296        du(ig, k) = ((detr(ig, k) + gamma(ig, k)) * ua(ig, k) - (entr(ig, k) + gamma(ig, &
     4297                k)) * u(ig, k) - wud(ig, k) + wud(ig, k + 1)) / masse(ig, k)
     4298        dv(ig, k) = ((detr(ig, k) + gamma(ig, k)) * va(ig, k) - (entr(ig, k) + gamma(ig, &
     4299                k)) * v(ig, k) - wvd(ig, k) + wvd(ig, k + 1)) / masse(ig, k)
     4300      END DO
     4301    END DO
     4302
     4303  END SUBROUTINE dvthermcell
     4304  SUBROUTINE dqthermcell2(ngrid, nlay, ptimestep, fm, entr, masse, frac, q, dq, &
     4305          qa)
     4306    USE dimphy
     4307    IMPLICIT NONE
     4308
     4309    ! =======================================================================
     4310
     4311    ! Calcul du transport verticale dans la couche limite en presence
     4312    ! de "thermiques" explicitement representes
     4313    ! calcul du dq/dt une fois qu'on connait les ascendances
     4314
     4315    ! =======================================================================
     4316
     4317    INTEGER ngrid, nlay
     4318
     4319    REAL ptimestep
     4320    REAL masse(ngrid, nlay), fm(ngrid, nlay + 1)
     4321    REAL entr(ngrid, nlay), frac(ngrid, nlay)
     4322    REAL q(ngrid, nlay)
     4323    REAL dq(ngrid, nlay)
     4324
     4325    REAL qa(klon, klev), detr(klon, klev), wqd(klon, klev + 1)
     4326    REAL qe(klon, klev), zf, zf2
     4327
     4328    INTEGER ig, k
     4329
     4330    ! calcul du detrainement
     4331
     4332    DO k = 1, nlay
     4333      DO ig = 1, ngrid
     4334        detr(ig, k) = fm(ig, k) - fm(ig, k + 1) + entr(ig, k)
     4335      END DO
     4336    END DO
     4337
     4338    ! calcul de la valeur dans les ascendances
     4339    DO ig = 1, ngrid
     4340      qa(ig, 1) = q(ig, 1)
     4341      qe(ig, 1) = q(ig, 1)
     4342    END DO
     4343
     4344    DO k = 2, nlay
     4345      DO ig = 1, ngrid
     4346        IF ((fm(ig, k + 1) + detr(ig, k)) * ptimestep>1.E-5 * masse(ig, k)) THEN
     4347          zf = 0.5 * (frac(ig, k) + frac(ig, k + 1))
     4348          zf2 = 1. / (1. - zf)
     4349          qa(ig, k) = (fm(ig, k) * qa(ig, k - 1) + zf2 * entr(ig, k) * q(ig, k)) / &
     4350                  (fm(ig, k + 1) + detr(ig, k) + entr(ig, k) * zf * zf2)
     4351          qe(ig, k) = (q(ig, k) - zf * qa(ig, k)) * zf2
     4352        ELSE
     4353          qa(ig, k) = q(ig, k)
     4354          qe(ig, k) = q(ig, k)
     4355        END IF
     4356      END DO
     4357    END DO
     4358
     4359    DO k = 2, nlay
     4360      DO ig = 1, ngrid
     4361        ! wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
     4362        wqd(ig, k) = fm(ig, k) * qe(ig, k)
     4363      END DO
     4364    END DO
     4365    DO ig = 1, ngrid
     4366      wqd(ig, 1) = 0.
     4367      wqd(ig, nlay + 1) = 0.
     4368    END DO
     4369
     4370    DO k = 1, nlay
     4371      DO ig = 1, ngrid
     4372        dq(ig, k) = (detr(ig, k) * qa(ig, k) - entr(ig, k) * qe(ig, k) - wqd(ig, k) + wqd(ig, k &
     4373                + 1)) / masse(ig, k)
     4374      END DO
     4375    END DO
     4376
     4377  END SUBROUTINE dqthermcell2
     4378  SUBROUTINE dvthermcell2(ngrid, nlay, ptimestep, fm, entr, masse, fraca, &
     4379          larga, u, v, du, dv, ua, va)
     4380    USE dimphy
     4381    IMPLICIT NONE
     4382
     4383    ! =======================================================================
     4384
     4385    ! Calcul du transport verticale dans la couche limite en presence
     4386    ! de "thermiques" explicitement representes
     4387    ! calcul du dq/dt une fois qu'on connait les ascendances
     4388
     4389    ! =======================================================================
     4390
     4391    INTEGER ngrid, nlay
     4392
     4393    REAL ptimestep
     4394    REAL masse(ngrid, nlay), fm(ngrid, nlay + 1)
     4395    REAL fraca(ngrid, nlay + 1)
     4396    REAL larga(ngrid)
     4397    REAL entr(ngrid, nlay)
     4398    REAL u(ngrid, nlay)
     4399    REAL ua(ngrid, nlay)
     4400    REAL du(ngrid, nlay)
     4401    REAL v(ngrid, nlay)
     4402    REAL va(ngrid, nlay)
     4403    REAL dv(ngrid, nlay)
     4404
     4405    REAL qa(klon, klev), detr(klon, klev), zf, zf2
     4406    REAL wvd(klon, klev + 1), wud(klon, klev + 1)
     4407    REAL gamma0, gamma(klon, klev + 1)
     4408    REAL ue(klon, klev), ve(klon, klev)
     4409    REAL dua, dva
     4410    INTEGER iter
     4411
     4412    INTEGER ig, k
     4413
     4414    ! calcul du detrainement
     4415
     4416    DO k = 1, nlay
     4417      DO ig = 1, ngrid
     4418        detr(ig, k) = fm(ig, k) - fm(ig, k + 1) + entr(ig, k)
     4419      END DO
     4420    END DO
     4421
     4422    ! calcul de la valeur dans les ascendances
     4423    DO ig = 1, ngrid
     4424      ua(ig, 1) = u(ig, 1)
     4425      va(ig, 1) = v(ig, 1)
     4426      ue(ig, 1) = u(ig, 1)
     4427      ve(ig, 1) = v(ig, 1)
     4428    END DO
     4429
     4430    DO k = 2, nlay
     4431      DO ig = 1, ngrid
     4432        IF ((fm(ig, k + 1) + detr(ig, k)) * ptimestep>1.E-5 * masse(ig, k)) THEN
     4433          ! On itère sur la valeur du coeff de freinage.
     4434          ! gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
     4435          gamma0 = masse(ig, k) * sqrt(0.5 * (fraca(ig, k + 1) + fraca(ig, &
     4436                  k))) * 0.5 / larga(ig) * 1.
     4437          ! s         *0.5
     4438          ! gamma0=0.
     4439          zf = 0.5 * (fraca(ig, k) + fraca(ig, k + 1))
     4440          zf = 0.
     4441          zf2 = 1. / (1. - zf)
     4442          ! la première fois on multiplie le coefficient de freinage
     4443          ! par le module du vent dans la couche en dessous.
     4444          dua = ua(ig, k - 1) - u(ig, k - 1)
     4445          dva = va(ig, k - 1) - v(ig, k - 1)
     4446          DO iter = 1, 5
     4447            ! On choisit une relaxation lineaire.
     4448            gamma(ig, k) = gamma0
     4449            ! On choisit une relaxation quadratique.
     4450            gamma(ig, k) = gamma0 * sqrt(dua**2 + dva**2)
     4451            ua(ig, k) = (fm(ig, k) * ua(ig, k - 1) + (zf2 * entr(ig, k) + gamma(ig, &
     4452                    k)) * u(ig, k)) / (fm(ig, k + 1) + detr(ig, k) + entr(ig, k) * zf * zf2 + gamma(ig, k) &
     4453                    )
     4454            va(ig, k) = (fm(ig, k) * va(ig, k - 1) + (zf2 * entr(ig, k) + gamma(ig, &
     4455                    k)) * v(ig, k)) / (fm(ig, k + 1) + detr(ig, k) + entr(ig, k) * zf * zf2 + gamma(ig, k) &
     4456                    )
     4457            ! PRINT*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
     4458            dua = ua(ig, k) - u(ig, k)
     4459            dva = va(ig, k) - v(ig, k)
     4460            ue(ig, k) = (u(ig, k) - zf * ua(ig, k)) * zf2
     4461            ve(ig, k) = (v(ig, k) - zf * va(ig, k)) * zf2
     4462          END DO
     4463        ELSE
     4464          ua(ig, k) = u(ig, k)
     4465          va(ig, k) = v(ig, k)
     4466          ue(ig, k) = u(ig, k)
     4467          ve(ig, k) = v(ig, k)
     4468          gamma(ig, k) = 0.
     4469        END IF
     4470      END DO
     4471    END DO
     4472
     4473    DO k = 2, nlay
     4474      DO ig = 1, ngrid
     4475        wud(ig, k) = fm(ig, k) * ue(ig, k)
     4476        wvd(ig, k) = fm(ig, k) * ve(ig, k)
     4477      END DO
     4478    END DO
     4479    DO ig = 1, ngrid
     4480      wud(ig, 1) = 0.
     4481      wud(ig, nlay + 1) = 0.
     4482      wvd(ig, 1) = 0.
     4483      wvd(ig, nlay + 1) = 0.
     4484    END DO
     4485
     4486    DO k = 1, nlay
     4487      DO ig = 1, ngrid
     4488        du(ig, k) = ((detr(ig, k) + gamma(ig, k)) * ua(ig, k) - (entr(ig, k) + gamma(ig, &
     4489                k)) * ue(ig, k) - wud(ig, k) + wud(ig, k + 1)) / masse(ig, k)
     4490        dv(ig, k) = ((detr(ig, k) + gamma(ig, k)) * va(ig, k) - (entr(ig, k) + gamma(ig, &
     4491                k)) * ve(ig, k) - wvd(ig, k) + wvd(ig, k + 1)) / masse(ig, k)
     4492      END DO
     4493    END DO
     4494
     4495  END SUBROUTINE dvthermcell2
     4496  SUBROUTINE thermcell_sec(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, &
     4497          pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s
     4498          ! ,pu_therm,pv_therm
     4499          , r_aspect, l_mix, w2di, tho)
     4500
     4501    USE dimphy
     4502    IMPLICIT NONE
     4503
     4504    ! =======================================================================
     4505
     4506    ! Calcul du transport verticale dans la couche limite en presence
     4507    ! de "thermiques" explicitement representes
     4508
     4509    ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
     4510
     4511    ! le thermique est supposé homogène et dissipé par mélange avec
     4512    ! son environnement. la longueur l_mix contrôle l'efficacité du
     4513    ! mélange
     4514
     4515    ! Le calcul du transport des différentes espèces se fait en prenant
     4516    ! en compte:
     4517    ! 1. un flux de masse montant
     4518    ! 2. un flux de masse descendant
     4519    ! 3. un entrainement
     4520    ! 4. un detrainement
     4521
     4522    ! =======================================================================
     4523
     4524    ! -----------------------------------------------------------------------
     4525    ! declarations:
     4526    ! -------------
     4527
     4528    include "YOMCST.h"
     4529
     4530    ! arguments:
     4531    ! ----------
     4532
     4533    INTEGER ngrid, nlay, w2di
     4534    REAL tho
     4535    REAL ptimestep, l_mix, r_aspect
     4536    REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
     4537    REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
     4538    REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
     4539    REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
     4540    REAL pplay(ngrid, nlay), pplev(ngrid, nlay + 1)
     4541    REAL pphi(ngrid, nlay)
     4542
     4543    INTEGER idetr
     4544    SAVE idetr
     4545    DATA idetr/3/
     4546    !$OMP THREADPRIVATE(idetr)
     4547
     4548    ! local:
     4549    ! ------
     4550
     4551    INTEGER ig, k, l, lmaxa(klon), lmix(klon)
     4552    REAL zsortie1d(klon)
     4553    ! CR: on remplace lmax(klon,klev+1)
     4554    INTEGER lmax(klon), lmin(klon), lentr(klon)
     4555    REAL linter(klon)
     4556    REAL zmix(klon), fracazmix(klon)
     4557    ! RC
     4558    REAL zmax(klon), zw, zz, zw2(klon, klev + 1), ztva(klon, klev), zzz
     4559
     4560    REAL zlev(klon, klev + 1), zlay(klon, klev)
     4561    REAL zh(klon, klev), zdhadj(klon, klev)
     4562    REAL ztv(klon, klev)
     4563    REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
     4564    REAL wh(klon, klev + 1)
     4565    REAL wu(klon, klev + 1), wv(klon, klev + 1), wo(klon, klev + 1)
     4566    REAL zla(klon, klev + 1)
     4567    REAL zwa(klon, klev + 1)
     4568    REAL zld(klon, klev + 1)
     4569    REAL zwd(klon, klev + 1)
     4570    REAL zsortie(klon, klev)
     4571    REAL zva(klon, klev)
     4572    REAL zua(klon, klev)
     4573    REAL zoa(klon, klev)
     4574
     4575    REAL zha(klon, klev)
     4576    REAL wa_moy(klon, klev + 1)
     4577    REAL fraca(klon, klev + 1)
     4578    REAL fracc(klon, klev + 1)
     4579    REAL zf, zf2
     4580    REAL thetath2(klon, klev), wth2(klon, klev)
     4581    ! common/comtherm/thetath2,wth2
     4582
     4583    REAL count_time
     4584    INTEGER ialt
     4585
     4586    LOGICAL sorties
     4587    REAL rho(klon, klev), rhobarz(klon, klev + 1), masse(klon, klev)
     4588    REAL zpspsk(klon, klev)
     4589
     4590    ! real wmax(klon,klev),wmaxa(klon)
     4591    REAL wmax(klon), wmaxa(klon)
     4592    REAL wa(klon, klev, klev + 1)
     4593    REAL wd(klon, klev + 1)
     4594    REAL larg_part(klon, klev, klev + 1)
     4595    REAL fracd(klon, klev + 1)
     4596    REAL xxx(klon, klev + 1)
     4597    REAL larg_cons(klon, klev + 1)
     4598    REAL larg_detr(klon, klev + 1)
     4599    REAL fm0(klon, klev + 1), entr0(klon, klev), detr(klon, klev)
     4600    REAL pu_therm(klon, klev), pv_therm(klon, klev)
     4601    REAL fm(klon, klev + 1), entr(klon, klev)
     4602    REAL fmc(klon, klev + 1)
     4603
     4604    ! CR:nouvelles variables
     4605    REAL f_star(klon, klev + 1), entr_star(klon, klev)
     4606    REAL entr_star_tot(klon), entr_star2(klon)
     4607    REAL f(klon), f0(klon)
     4608    REAL zlevinter(klon)
     4609    LOGICAL first
     4610    DATA first/.FALSE./
     4611    SAVE first
     4612    !$OMP THREADPRIVATE(first)
     4613    ! RC
     4614
     4615    CHARACTER *2 str2
     4616    CHARACTER *10 str10
     4617
     4618    CHARACTER (LEN = 20) :: modname = 'thermcell_sec'
     4619    CHARACTER (LEN = 80) :: abort_message
     4620
     4621    LOGICAL vtest(klon), down
     4622
     4623    INTEGER ncorrec, ll
     4624    SAVE ncorrec
     4625    DATA ncorrec/0/
     4626    !$OMP THREADPRIVATE(ncorrec)
     4627
     4628
     4629    ! -----------------------------------------------------------------------
     4630    ! initialisation:
     4631    ! ---------------
     4632
     4633    sorties = .TRUE.
     4634    IF (ngrid/=klon) THEN
     4635      PRINT *
     4636      PRINT *, 'STOP dans convadj'
     4637      PRINT *, 'ngrid    =', ngrid
     4638      PRINT *, 'klon  =', klon
     4639    END IF
     4640
     4641    ! -----------------------------------------------------------------------
     4642    ! incrementation eventuelle de tendances precedentes:
     4643    ! ---------------------------------------------------
     4644
     4645    ! PRINT*,'0 OK convect8'
     4646
     4647    DO l = 1, nlay
     4648      DO ig = 1, ngrid
     4649        zpspsk(ig, l) = (pplay(ig, l) / pplev(ig, 1))**rkappa
     4650        zh(ig, l) = pt(ig, l) / zpspsk(ig, l)
     4651        zu(ig, l) = pu(ig, l)
     4652        zv(ig, l) = pv(ig, l)
     4653        zo(ig, l) = po(ig, l)
     4654        ztv(ig, l) = zh(ig, l) * (1. + 0.61 * zo(ig, l))
     4655      END DO
     4656    END DO
     4657
     4658    ! PRINT*,'1 OK convect8'
     4659    ! --------------------
     4660
     4661
     4662    ! + + + + + + + + + + +
     4663
     4664
     4665    ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
     4666    ! wh,wt,wo ...
     4667
     4668    ! + + + + + + + + + + +  zh,zu,zv,zo,rho
     4669
     4670
     4671    ! --------------------   zlev(1)
     4672    ! \\\\\\\\\\\\\\\\\\\\
     4673
     4674
     4675
     4676    ! -----------------------------------------------------------------------
     4677    ! Calcul des altitudes des couches
     4678    ! -----------------------------------------------------------------------
     4679
     4680    DO l = 2, nlay
     4681      DO ig = 1, ngrid
     4682        zlev(ig, l) = 0.5 * (pphi(ig, l) + pphi(ig, l - 1)) / rg
     4683      END DO
     4684    END DO
     4685    DO ig = 1, ngrid
     4686      zlev(ig, 1) = 0.
     4687      zlev(ig, nlay + 1) = (2. * pphi(ig, klev) - pphi(ig, klev - 1)) / rg
     4688    END DO
     4689    DO l = 1, nlay
     4690      DO ig = 1, ngrid
     4691        zlay(ig, l) = pphi(ig, l) / rg
     4692      END DO
     4693    END DO
     4694
     4695    ! PRINT*,'2 OK convect8'
     4696    ! -----------------------------------------------------------------------
     4697    ! Calcul des densites
     4698    ! -----------------------------------------------------------------------
     4699
     4700    DO l = 1, nlay
     4701      DO ig = 1, ngrid
     4702        rho(ig, l) = pplay(ig, l) / (zpspsk(ig, l) * rd * zh(ig, l))
     4703      END DO
     4704    END DO
     4705
     4706    DO l = 2, nlay
     4707      DO ig = 1, ngrid
     4708        rhobarz(ig, l) = 0.5 * (rho(ig, l) + rho(ig, l - 1))
     4709      END DO
     4710    END DO
     4711
     4712    DO k = 1, nlay
     4713      DO l = 1, nlay + 1
     4714        DO ig = 1, ngrid
     4715          wa(ig, k, l) = 0.
     4716        END DO
     4717      END DO
     4718    END DO
     4719
     4720    ! PRINT*,'3 OK convect8'
     4721    ! ------------------------------------------------------------------
     4722    ! Calcul de w2, quarre de w a partir de la cape
     4723    ! a partir de w2, on calcule wa, vitesse de l'ascendance
     4724
     4725    ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
     4726    ! w2 est stoke dans wa
     4727
     4728    ! ATTENTION: dans convect8, on n'utilise le calcule des wa
     4729    ! independants par couches que pour calculer l'entrainement
     4730    ! a la base et la hauteur max de l'ascendance.
     4731
     4732    ! Indicages:
     4733    ! l'ascendance provenant du niveau k traverse l'interface l avec
     4734    ! une vitesse wa(k,l).
     4735
     4736    ! --------------------
     4737
     4738    ! + + + + + + + + + +
     4739
     4740    ! wa(k,l)   ----       --------------------    l
     4741    ! /\
     4742    ! /||\       + + + + + + + + + +
     4743    ! ||
     4744    ! ||        --------------------
     4745    ! ||
     4746    ! ||        + + + + + + + + + +
     4747    ! ||
     4748    ! ||        --------------------
     4749    ! ||__
     4750    ! |___      + + + + + + + + + +     k
     4751
     4752    ! --------------------
     4753
     4754
     4755
     4756    ! ------------------------------------------------------------------
     4757
     4758    ! CR: ponderation entrainement des couches instables
     4759    ! def des entr_star tels que entr=f*entr_star
     4760    DO l = 1, klev
     4761      DO ig = 1, ngrid
     4762        entr_star(ig, l) = 0.
     4763      END DO
     4764    END DO
     4765    ! determination de la longueur de la couche d entrainement
     4766    DO ig = 1, ngrid
     4767      lentr(ig) = 1
     4768    END DO
     4769
     4770    ! on ne considere que les premieres couches instables
     4771    DO k = nlay - 2, 1, -1
     4772      DO ig = 1, ngrid
     4773        IF (ztv(ig, k)>ztv(ig, k + 1) .AND. ztv(ig, k + 1)<=ztv(ig, k + 2)) THEN
     4774          lentr(ig) = k
     4775        END IF
     4776      END DO
     4777    END DO
     4778
     4779    ! determination du lmin: couche d ou provient le thermique
     4780    DO ig = 1, ngrid
     4781      lmin(ig) = 1
     4782    END DO
     4783    DO ig = 1, ngrid
     4784      DO l = nlay, 2, -1
     4785        IF (ztv(ig, l - 1)>ztv(ig, l)) THEN
     4786          lmin(ig) = l - 1
     4787        END IF
     4788      END DO
     4789    END DO
     4790
     4791    ! definition de l'entrainement des couches
     4792    DO l = 1, klev - 1
     4793      DO ig = 1, ngrid
     4794        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN
     4795          entr_star(ig, l) = (ztv(ig, l) - ztv(ig, l + 1))** & ! s
     4796                  ! (zlev(ig,l+1)-zlev(ig,l))
     4797                  sqrt(zlev(ig, l + 1))
     4798        END IF
     4799      END DO
     4800    END DO
     4801    ! pas de thermique si couche 1 stable
     4802    DO ig = 1, ngrid
     4803      IF (lmin(ig)>1) THEN
     4804        DO l = 1, klev
     4805          entr_star(ig, l) = 0.
     4806        END DO
    41624807      END IF
    4163       IF (fm(ig,k+1)<0.) THEN
    4164         ! PRINT*,'fm2<0!!!'
     4808    END DO
     4809    ! calcul de l entrainement total
     4810    DO ig = 1, ngrid
     4811      entr_star_tot(ig) = 0.
     4812    END DO
     4813    DO ig = 1, ngrid
     4814      DO k = 1, klev
     4815        entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k)
     4816      END DO
     4817    END DO
     4818
     4819    ! PRINT*,'fin calcul entr_star'
     4820    DO k = 1, klev
     4821      DO ig = 1, ngrid
     4822        ztva(ig, k) = ztv(ig, k)
     4823      END DO
     4824    END DO
     4825    ! RC
     4826    ! PRINT*,'7 OK convect8'
     4827    DO k = 1, klev + 1
     4828      DO ig = 1, ngrid
     4829        zw2(ig, k) = 0.
     4830        fmc(ig, k) = 0.
     4831        ! CR
     4832        f_star(ig, k) = 0.
     4833        ! RC
     4834        larg_cons(ig, k) = 0.
     4835        larg_detr(ig, k) = 0.
     4836        wa_moy(ig, k) = 0.
     4837      END DO
     4838    END DO
     4839
     4840    ! PRINT*,'8 OK convect8'
     4841    DO ig = 1, ngrid
     4842      linter(ig) = 1.
     4843      lmaxa(ig) = 1
     4844      lmix(ig) = 1
     4845      wmaxa(ig) = 0.
     4846    END DO
     4847
     4848    ! CR:
     4849    DO l = 1, nlay - 2
     4850      DO ig = 1, ngrid
     4851        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. entr_star(ig, l)>1.E-10 .AND. &
     4852                zw2(ig, l)<1E-10) THEN
     4853          f_star(ig, l + 1) = entr_star(ig, l)
     4854          ! test:calcul de dteta
     4855          zw2(ig, l + 1) = 2. * rg * (ztv(ig, l) - ztv(ig, l + 1)) / ztv(ig, l + 1) * &
     4856                  (zlev(ig, l + 1) - zlev(ig, l)) * 0.4 * pphi(ig, l) / (pphi(ig, l + 1) - pphi(ig, l))
     4857          larg_detr(ig, l) = 0.
     4858        ELSE IF ((zw2(ig, l)>=1E-10) .AND. (f_star(ig, l) + entr_star(ig, &
     4859                l)>1.E-10)) THEN
     4860          f_star(ig, l + 1) = f_star(ig, l) + entr_star(ig, l)
     4861          ztva(ig, l) = (f_star(ig, l) * ztva(ig, l - 1) + entr_star(ig, l) * ztv(ig, l)) / &
     4862                  f_star(ig, l + 1)
     4863          zw2(ig, l + 1) = zw2(ig, l) * (f_star(ig, l) / f_star(ig, l + 1))**2 + &
     4864                  2. * rg * (ztva(ig, l) - ztv(ig, l)) / ztv(ig, l) * (zlev(ig, l + 1) - zlev(ig, l))
     4865        END IF
     4866        ! determination de zmax continu par interpolation lineaire
     4867        IF (zw2(ig, l + 1)<0.) THEN
     4868          ! test
     4869          IF (abs(zw2(ig, l + 1) - zw2(ig, l))<1E-10) THEN
     4870            ! PRINT*,'pb linter'
     4871          END IF
     4872          linter(ig) = (l * (zw2(ig, l + 1) - zw2(ig, l)) - zw2(ig, l)) / (zw2(ig, l + 1) - zw2(&
     4873                  ig, l))
     4874          zw2(ig, l + 1) = 0.
     4875          lmaxa(ig) = l
     4876        ELSE
     4877          IF (zw2(ig, l + 1)<0.) THEN
     4878            ! PRINT*,'pb1 zw2<0'
     4879          END IF
     4880          wa_moy(ig, l + 1) = sqrt(zw2(ig, l + 1))
     4881        END IF
     4882        IF (wa_moy(ig, l + 1)>wmaxa(ig)) THEN
     4883          ! lmix est le niveau de la couche ou w (wa_moy) est maximum
     4884          lmix(ig) = l + 1
     4885          wmaxa(ig) = wa_moy(ig, l + 1)
     4886        END IF
     4887      END DO
     4888    END DO
     4889    ! PRINT*,'fin calcul zw2'
     4890
     4891    ! Calcul de la couche correspondant a la hauteur du thermique
     4892    DO ig = 1, ngrid
     4893      lmax(ig) = lentr(ig)
     4894    END DO
     4895    DO ig = 1, ngrid
     4896      DO l = nlay, lentr(ig) + 1, -1
     4897        IF (zw2(ig, l)<=1.E-10) THEN
     4898          lmax(ig) = l - 1
     4899        END IF
     4900      END DO
     4901    END DO
     4902    ! pas de thermique si couche 1 stable
     4903    DO ig = 1, ngrid
     4904      IF (lmin(ig)>1) THEN
     4905        lmax(ig) = 1
     4906        lmin(ig) = 1
    41654907      END IF
    4166       IF (entr(ig,k)<0.) THEN
    4167         ! PRINT*,'entr2<0!!!'
    4168       END IF
    4169     END DO
    4170   END DO
    4171 
    4172   ! calcul de la valeur dans les ascendances
    4173   DO ig = 1, ngrid
    4174     qa(ig, 1) = q(ig, 1)
    4175   END DO
    4176 
    4177   DO k = 2, nlay
    4178     DO ig = 1, ngrid
    4179       IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN
    4180         qa(ig, k) = (fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))/ &
    4181           (fm(ig,k+1)+detr(ig,k))
     4908    END DO
     4909
     4910    ! Determination de zw2 max
     4911    DO ig = 1, ngrid
     4912      wmax(ig) = 0.
     4913    END DO
     4914
     4915    DO l = 1, nlay
     4916      DO ig = 1, ngrid
     4917        IF (l<=lmax(ig)) THEN
     4918          IF (zw2(ig, l)<0.) THEN
     4919            ! PRINT*,'pb2 zw2<0'
     4920          END IF
     4921          zw2(ig, l) = sqrt(zw2(ig, l))
     4922          wmax(ig) = max(wmax(ig), zw2(ig, l))
     4923        ELSE
     4924          zw2(ig, l) = 0.
     4925        END IF
     4926      END DO
     4927    END DO
     4928
     4929    ! Longueur caracteristique correspondant a la hauteur des thermiques.
     4930    DO ig = 1, ngrid
     4931      zmax(ig) = 0.
     4932      zlevinter(ig) = zlev(ig, 1)
     4933    END DO
     4934    DO ig = 1, ngrid
     4935      ! calcul de zlevinter
     4936      zlevinter(ig) = (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig))) * linter(ig) + &
     4937              zlev(ig, lmax(ig)) - lmax(ig) * (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig)))
     4938      zmax(ig) = max(zmax(ig), zlevinter(ig) - zlev(ig, lmin(ig)))
     4939    END DO
     4940
     4941    ! PRINT*,'avant fermeture'
     4942    ! Fermeture,determination de f
     4943    DO ig = 1, ngrid
     4944      entr_star2(ig) = 0.
     4945    END DO
     4946    DO ig = 1, ngrid
     4947      IF (entr_star_tot(ig)<1.E-10) THEN
     4948        f(ig) = 0.
    41824949      ELSE
    4183         qa(ig, k) = q(ig, k)
    4184       END IF
    4185       IF (qa(ig,k)<0.) THEN
    4186         ! PRINT*,'qa<0!!!'
    4187       END IF
    4188       IF (q(ig,k)<0.) THEN
    4189         ! PRINT*,'q<0!!!'
    4190       END IF
    4191     END DO
    4192   END DO
    4193 
    4194   DO k = 2, nlay
    4195     DO ig = 1, ngrid
    4196       ! wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
    4197       wqd(ig, k) = fm(ig, k)*q(ig, k)
    4198       IF (wqd(ig,k)<0.) THEN
    4199         ! PRINT*,'wqd<0!!!'
    4200       END IF
    4201     END DO
    4202   END DO
    4203   DO ig = 1, ngrid
    4204     wqd(ig, 1) = 0.
    4205     wqd(ig, nlay+1) = 0.
    4206   END DO
    4207 
    4208   DO k = 1, nlay
    4209     DO ig = 1, ngrid
    4210       dq(ig, k) = (detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)-wqd(ig,k)+wqd(ig,k+ &
    4211         1))/masse(ig, k)
    4212       ! if (dq(ig,k).lt.0.) THEN
    4213       ! PRINT*,'dq<0!!!'
    4214       ! END IF
    4215     END DO
    4216   END DO
    4217 
    4218 
    4219 END SUBROUTINE dqthermcell
    4220 SUBROUTINE dvthermcell(ngrid, nlay, ptimestep, fm, entr, masse, fraca, larga, &
    4221     u, v, du, dv, ua, va)
    4222   USE dimphy
    4223   IMPLICIT NONE
    4224 
    4225   ! =======================================================================
    4226 
    4227   ! Calcul du transport verticale dans la couche limite en presence
    4228   ! de "thermiques" explicitement representes
    4229   ! calcul du dq/dt une fois qu'on connait les ascendances
    4230 
    4231   ! =======================================================================
    4232 
    4233   INTEGER ngrid, nlay
    4234 
    4235   REAL ptimestep
    4236   REAL masse(ngrid, nlay), fm(ngrid, nlay+1)
    4237   REAL fraca(ngrid, nlay+1)
    4238   REAL larga(ngrid)
    4239   REAL entr(ngrid, nlay)
    4240   REAL u(ngrid, nlay)
    4241   REAL ua(ngrid, nlay)
    4242   REAL du(ngrid, nlay)
    4243   REAL v(ngrid, nlay)
    4244   REAL va(ngrid, nlay)
    4245   REAL dv(ngrid, nlay)
    4246 
    4247   REAL qa(klon, klev), detr(klon, klev)
    4248   REAL wvd(klon, klev+1), wud(klon, klev+1)
    4249   REAL gamma0, gamma(klon, klev+1)
    4250   REAL dua, dva
    4251   INTEGER iter
    4252 
    4253   INTEGER ig, k
    4254 
    4255   ! calcul du detrainement
    4256 
    4257   DO k = 1, nlay
    4258     DO ig = 1, ngrid
    4259       detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k)
    4260     END DO
    4261   END DO
    4262 
    4263   ! calcul de la valeur dans les ascendances
    4264   DO ig = 1, ngrid
    4265     ua(ig, 1) = u(ig, 1)
    4266     va(ig, 1) = v(ig, 1)
    4267   END DO
    4268 
    4269   DO k = 2, nlay
    4270     DO ig = 1, ngrid
    4271       IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN
    4272         ! On itère sur la valeur du coeff de freinage.
    4273         ! gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
    4274         gamma0 = masse(ig, k)*sqrt(0.5*(fraca(ig,k+1)+fraca(ig, &
    4275           k)))*0.5/larga(ig)
    4276         ! gamma0=0.
    4277         ! la première fois on multiplie le coefficient de freinage
    4278         ! par le module du vent dans la couche en dessous.
    4279         dua = ua(ig, k-1) - u(ig, k-1)
    4280         dva = va(ig, k-1) - v(ig, k-1)
    4281         DO iter = 1, 5
    4282           gamma(ig, k) = gamma0*sqrt(dua**2+dva**2)
    4283           ua(ig, k) = (fm(ig,k)*ua(ig,k-1)+(entr(ig,k)+gamma(ig, &
    4284             k))*u(ig,k))/(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
    4285           va(ig, k) = (fm(ig,k)*va(ig,k-1)+(entr(ig,k)+gamma(ig, &
    4286             k))*v(ig,k))/(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
    4287           ! PRINT*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
    4288           dua = ua(ig, k) - u(ig, k)
    4289           dva = va(ig, k) - v(ig, k)
     4950        DO k = lmin(ig), lentr(ig)
     4951          entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2 / (rho(ig, k) * (&
     4952                  zlev(ig, k + 1) - zlev(ig, k)))
    42904953        END DO
    4291       ELSE
    4292         ua(ig, k) = u(ig, k)
    4293         va(ig, k) = v(ig, k)
    4294         gamma(ig, k) = 0.
    4295       END IF
    4296     END DO
    4297   END DO
    4298 
    4299   DO k = 2, nlay
    4300     DO ig = 1, ngrid
    4301       wud(ig, k) = fm(ig, k)*u(ig, k)
    4302       wvd(ig, k) = fm(ig, k)*v(ig, k)
    4303     END DO
    4304   END DO
    4305   DO ig = 1, ngrid
    4306     wud(ig, 1) = 0.
    4307     wud(ig, nlay+1) = 0.
    4308     wvd(ig, 1) = 0.
    4309     wvd(ig, nlay+1) = 0.
    4310   END DO
    4311 
    4312   DO k = 1, nlay
    4313     DO ig = 1, ngrid
    4314       du(ig, k) = ((detr(ig,k)+gamma(ig,k))*ua(ig,k)-(entr(ig,k)+gamma(ig, &
    4315         k))*u(ig,k)-wud(ig,k)+wud(ig,k+1))/masse(ig, k)
    4316       dv(ig, k) = ((detr(ig,k)+gamma(ig,k))*va(ig,k)-(entr(ig,k)+gamma(ig, &
    4317         k))*v(ig,k)-wvd(ig,k)+wvd(ig,k+1))/masse(ig, k)
    4318     END DO
    4319   END DO
    4320 
    4321 
    4322 END SUBROUTINE dvthermcell
    4323 SUBROUTINE dqthermcell2(ngrid, nlay, ptimestep, fm, entr, masse, frac, q, dq, &
    4324     qa)
    4325   USE dimphy
    4326   IMPLICIT NONE
    4327 
    4328   ! =======================================================================
    4329 
    4330   ! Calcul du transport verticale dans la couche limite en presence
    4331   ! de "thermiques" explicitement representes
    4332   ! calcul du dq/dt une fois qu'on connait les ascendances
    4333 
    4334   ! =======================================================================
    4335 
    4336   INTEGER ngrid, nlay
    4337 
    4338   REAL ptimestep
    4339   REAL masse(ngrid, nlay), fm(ngrid, nlay+1)
    4340   REAL entr(ngrid, nlay), frac(ngrid, nlay)
    4341   REAL q(ngrid, nlay)
    4342   REAL dq(ngrid, nlay)
    4343 
    4344   REAL qa(klon, klev), detr(klon, klev), wqd(klon, klev+1)
    4345   REAL qe(klon, klev), zf, zf2
    4346 
    4347   INTEGER ig, k
    4348 
    4349   ! calcul du detrainement
    4350 
    4351   DO k = 1, nlay
    4352     DO ig = 1, ngrid
    4353       detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k)
    4354     END DO
    4355   END DO
    4356 
    4357   ! calcul de la valeur dans les ascendances
    4358   DO ig = 1, ngrid
    4359     qa(ig, 1) = q(ig, 1)
    4360     qe(ig, 1) = q(ig, 1)
    4361   END DO
    4362 
    4363   DO k = 2, nlay
    4364     DO ig = 1, ngrid
    4365       IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN
    4366         zf = 0.5*(frac(ig,k)+frac(ig,k+1))
    4367         zf2 = 1./(1.-zf)
    4368         qa(ig, k) = (fm(ig,k)*qa(ig,k-1)+zf2*entr(ig,k)*q(ig,k))/ &
    4369           (fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2)
    4370         qe(ig, k) = (q(ig,k)-zf*qa(ig,k))*zf2
    4371       ELSE
    4372         qa(ig, k) = q(ig, k)
    4373         qe(ig, k) = q(ig, k)
    4374       END IF
    4375     END DO
    4376   END DO
    4377 
    4378   DO k = 2, nlay
    4379     DO ig = 1, ngrid
    4380       ! wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
    4381       wqd(ig, k) = fm(ig, k)*qe(ig, k)
    4382     END DO
    4383   END DO
    4384   DO ig = 1, ngrid
    4385     wqd(ig, 1) = 0.
    4386     wqd(ig, nlay+1) = 0.
    4387   END DO
    4388 
    4389   DO k = 1, nlay
    4390     DO ig = 1, ngrid
    4391       dq(ig, k) = (detr(ig,k)*qa(ig,k)-entr(ig,k)*qe(ig,k)-wqd(ig,k)+wqd(ig,k &
    4392         +1))/masse(ig, k)
    4393     END DO
    4394   END DO
    4395 
    4396 
    4397 END SUBROUTINE dqthermcell2
    4398 SUBROUTINE dvthermcell2(ngrid, nlay, ptimestep, fm, entr, masse, fraca, &
    4399     larga, u, v, du, dv, ua, va)
    4400   USE dimphy
    4401   IMPLICIT NONE
    4402 
    4403   ! =======================================================================
    4404 
    4405   ! Calcul du transport verticale dans la couche limite en presence
    4406   ! de "thermiques" explicitement representes
    4407   ! calcul du dq/dt une fois qu'on connait les ascendances
    4408 
    4409   ! =======================================================================
    4410 
    4411   INTEGER ngrid, nlay
    4412 
    4413   REAL ptimestep
    4414   REAL masse(ngrid, nlay), fm(ngrid, nlay+1)
    4415   REAL fraca(ngrid, nlay+1)
    4416   REAL larga(ngrid)
    4417   REAL entr(ngrid, nlay)
    4418   REAL u(ngrid, nlay)
    4419   REAL ua(ngrid, nlay)
    4420   REAL du(ngrid, nlay)
    4421   REAL v(ngrid, nlay)
    4422   REAL va(ngrid, nlay)
    4423   REAL dv(ngrid, nlay)
    4424 
    4425   REAL qa(klon, klev), detr(klon, klev), zf, zf2
    4426   REAL wvd(klon, klev+1), wud(klon, klev+1)
    4427   REAL gamma0, gamma(klon, klev+1)
    4428   REAL ue(klon, klev), ve(klon, klev)
    4429   REAL dua, dva
    4430   INTEGER iter
    4431 
    4432   INTEGER ig, k
    4433 
    4434   ! calcul du detrainement
    4435 
    4436   DO k = 1, nlay
    4437     DO ig = 1, ngrid
    4438       detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k)
    4439     END DO
    4440   END DO
    4441 
    4442   ! calcul de la valeur dans les ascendances
    4443   DO ig = 1, ngrid
    4444     ua(ig, 1) = u(ig, 1)
    4445     va(ig, 1) = v(ig, 1)
    4446     ue(ig, 1) = u(ig, 1)
    4447     ve(ig, 1) = v(ig, 1)
    4448   END DO
    4449 
    4450   DO k = 2, nlay
    4451     DO ig = 1, ngrid
    4452       IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN
    4453         ! On itère sur la valeur du coeff de freinage.
    4454         ! gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
    4455         gamma0 = masse(ig, k)*sqrt(0.5*(fraca(ig,k+1)+fraca(ig, &
    4456           k)))*0.5/larga(ig)*1.
    4457         ! s         *0.5
    4458         ! gamma0=0.
    4459         zf = 0.5*(fraca(ig,k)+fraca(ig,k+1))
    4460         zf = 0.
    4461         zf2 = 1./(1.-zf)
    4462         ! la première fois on multiplie le coefficient de freinage
    4463         ! par le module du vent dans la couche en dessous.
    4464         dua = ua(ig, k-1) - u(ig, k-1)
    4465         dva = va(ig, k-1) - v(ig, k-1)
    4466         DO iter = 1, 5
    4467           ! On choisit une relaxation lineaire.
    4468           gamma(ig, k) = gamma0
    4469           ! On choisit une relaxation quadratique.
    4470           gamma(ig, k) = gamma0*sqrt(dua**2+dva**2)
    4471           ua(ig, k) = (fm(ig,k)*ua(ig,k-1)+(zf2*entr(ig,k)+gamma(ig, &
    4472             k))*u(ig,k))/(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2+gamma(ig,k) &
    4473             )
    4474           va(ig, k) = (fm(ig,k)*va(ig,k-1)+(zf2*entr(ig,k)+gamma(ig, &
    4475             k))*v(ig,k))/(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2+gamma(ig,k) &
    4476             )
    4477           ! PRINT*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
    4478           dua = ua(ig, k) - u(ig, k)
    4479           dva = va(ig, k) - v(ig, k)
    4480           ue(ig, k) = (u(ig,k)-zf*ua(ig,k))*zf2
    4481           ve(ig, k) = (v(ig,k)-zf*va(ig,k))*zf2
    4482         END DO
    4483       ELSE
    4484         ua(ig, k) = u(ig, k)
    4485         va(ig, k) = v(ig, k)
    4486         ue(ig, k) = u(ig, k)
    4487         ve(ig, k) = v(ig, k)
    4488         gamma(ig, k) = 0.
    4489       END IF
    4490     END DO
    4491   END DO
    4492 
    4493   DO k = 2, nlay
    4494     DO ig = 1, ngrid
    4495       wud(ig, k) = fm(ig, k)*ue(ig, k)
    4496       wvd(ig, k) = fm(ig, k)*ve(ig, k)
    4497     END DO
    4498   END DO
    4499   DO ig = 1, ngrid
    4500     wud(ig, 1) = 0.
    4501     wud(ig, nlay+1) = 0.
    4502     wvd(ig, 1) = 0.
    4503     wvd(ig, nlay+1) = 0.
    4504   END DO
    4505 
    4506   DO k = 1, nlay
    4507     DO ig = 1, ngrid
    4508       du(ig, k) = ((detr(ig,k)+gamma(ig,k))*ua(ig,k)-(entr(ig,k)+gamma(ig, &
    4509         k))*ue(ig,k)-wud(ig,k)+wud(ig,k+1))/masse(ig, k)
    4510       dv(ig, k) = ((detr(ig,k)+gamma(ig,k))*va(ig,k)-(entr(ig,k)+gamma(ig, &
    4511         k))*ve(ig,k)-wvd(ig,k)+wvd(ig,k+1))/masse(ig, k)
    4512     END DO
    4513   END DO
    4514 
    4515 
    4516 END SUBROUTINE dvthermcell2
    4517 SUBROUTINE thermcell_sec(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, &
    4518     pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s
    4519                                                                  ! ,pu_therm,pv_therm
    4520     , r_aspect, l_mix, w2di, tho)
    4521 
    4522   USE dimphy
    4523   IMPLICIT NONE
    4524 
    4525   ! =======================================================================
    4526 
    4527   ! Calcul du transport verticale dans la couche limite en presence
    4528   ! de "thermiques" explicitement representes
    4529 
    4530   ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
    4531 
    4532   ! le thermique est supposé homogène et dissipé par mélange avec
    4533   ! son environnement. la longueur l_mix contrôle l'efficacité du
    4534   ! mélange
    4535 
    4536   ! Le calcul du transport des différentes espèces se fait en prenant
    4537   ! en compte:
    4538   ! 1. un flux de masse montant
    4539   ! 2. un flux de masse descendant
    4540   ! 3. un entrainement
    4541   ! 4. un detrainement
    4542 
    4543   ! =======================================================================
    4544 
    4545   ! -----------------------------------------------------------------------
    4546   ! declarations:
    4547   ! -------------
    4548 
    4549   include "YOMCST.h"
    4550 
    4551   ! arguments:
    4552   ! ----------
    4553 
    4554   INTEGER ngrid, nlay, w2di
    4555   REAL tho
    4556   REAL ptimestep, l_mix, r_aspect
    4557   REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
    4558   REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
    4559   REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
    4560   REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
    4561   REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1)
    4562   REAL pphi(ngrid, nlay)
    4563 
    4564   INTEGER idetr
    4565   SAVE idetr
    4566   DATA idetr/3/
    4567   !$OMP THREADPRIVATE(idetr)
    4568 
    4569   ! local:
    4570   ! ------
    4571 
    4572   INTEGER ig, k, l, lmaxa(klon), lmix(klon)
    4573   REAL zsortie1d(klon)
    4574   ! CR: on remplace lmax(klon,klev+1)
    4575   INTEGER lmax(klon), lmin(klon), lentr(klon)
    4576   REAL linter(klon)
    4577   REAL zmix(klon), fracazmix(klon)
    4578   ! RC
    4579   REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz
    4580 
    4581   REAL zlev(klon, klev+1), zlay(klon, klev)
    4582   REAL zh(klon, klev), zdhadj(klon, klev)
    4583   REAL ztv(klon, klev)
    4584   REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
    4585   REAL wh(klon, klev+1)
    4586   REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1)
    4587   REAL zla(klon, klev+1)
    4588   REAL zwa(klon, klev+1)
    4589   REAL zld(klon, klev+1)
    4590   REAL zwd(klon, klev+1)
    4591   REAL zsortie(klon, klev)
    4592   REAL zva(klon, klev)
    4593   REAL zua(klon, klev)
    4594   REAL zoa(klon, klev)
    4595 
    4596   REAL zha(klon, klev)
    4597   REAL wa_moy(klon, klev+1)
    4598   REAL fraca(klon, klev+1)
    4599   REAL fracc(klon, klev+1)
    4600   REAL zf, zf2
    4601   REAL thetath2(klon, klev), wth2(klon, klev)
    4602   ! common/comtherm/thetath2,wth2
    4603 
    4604   REAL count_time
    4605   INTEGER ialt
    4606 
    4607   LOGICAL sorties
    4608   REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev)
    4609   REAL zpspsk(klon, klev)
    4610 
    4611   ! real wmax(klon,klev),wmaxa(klon)
    4612   REAL wmax(klon), wmaxa(klon)
    4613   REAL wa(klon, klev, klev+1)
    4614   REAL wd(klon, klev+1)
    4615   REAL larg_part(klon, klev, klev+1)
    4616   REAL fracd(klon, klev+1)
    4617   REAL xxx(klon, klev+1)
    4618   REAL larg_cons(klon, klev+1)
    4619   REAL larg_detr(klon, klev+1)
    4620   REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev)
    4621   REAL pu_therm(klon, klev), pv_therm(klon, klev)
    4622   REAL fm(klon, klev+1), entr(klon, klev)
    4623   REAL fmc(klon, klev+1)
    4624 
    4625   ! CR:nouvelles variables
    4626   REAL f_star(klon, klev+1), entr_star(klon, klev)
    4627   REAL entr_star_tot(klon), entr_star2(klon)
    4628   REAL f(klon), f0(klon)
    4629   REAL zlevinter(klon)
    4630   LOGICAL first
    4631   DATA first/.FALSE./
    4632   SAVE first
    4633   !$OMP THREADPRIVATE(first)
    4634   ! RC
    4635 
    4636   CHARACTER *2 str2
    4637   CHARACTER *10 str10
    4638 
    4639   CHARACTER (LEN=20) :: modname = 'thermcell_sec'
    4640   CHARACTER (LEN=80) :: abort_message
    4641 
    4642   LOGICAL vtest(klon), down
    4643 
    4644   EXTERNAL scopy
    4645 
    4646   INTEGER ncorrec, ll
    4647   SAVE ncorrec
    4648   DATA ncorrec/0/
    4649   !$OMP THREADPRIVATE(ncorrec)
    4650 
    4651 
    4652   ! -----------------------------------------------------------------------
    4653   ! initialisation:
    4654   ! ---------------
    4655 
    4656   sorties = .TRUE.
    4657   IF (ngrid/=klon) THEN
    4658     PRINT *
    4659     PRINT *, 'STOP dans convadj'
    4660     PRINT *, 'ngrid    =', ngrid
    4661     PRINT *, 'klon  =', klon
    4662   END IF
    4663 
    4664   ! -----------------------------------------------------------------------
    4665   ! incrementation eventuelle de tendances precedentes:
    4666   ! ---------------------------------------------------
    4667 
    4668   ! PRINT*,'0 OK convect8'
    4669 
    4670   DO l = 1, nlay
    4671     DO ig = 1, ngrid
    4672       zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa
    4673       zh(ig, l) = pt(ig, l)/zpspsk(ig, l)
    4674       zu(ig, l) = pu(ig, l)
    4675       zv(ig, l) = pv(ig, l)
    4676       zo(ig, l) = po(ig, l)
    4677       ztv(ig, l) = zh(ig, l)*(1.+0.61*zo(ig,l))
    4678     END DO
    4679   END DO
    4680 
    4681   ! PRINT*,'1 OK convect8'
    4682   ! --------------------
    4683 
    4684 
    4685   ! + + + + + + + + + + +
    4686 
    4687 
    4688   ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
    4689   ! wh,wt,wo ...
    4690 
    4691   ! + + + + + + + + + + +  zh,zu,zv,zo,rho
    4692 
    4693 
    4694   ! --------------------   zlev(1)
    4695   ! \\\\\\\\\\\\\\\\\\\\
    4696 
    4697 
    4698 
    4699   ! -----------------------------------------------------------------------
    4700   ! Calcul des altitudes des couches
    4701   ! -----------------------------------------------------------------------
    4702 
    4703   DO l = 2, nlay
    4704     DO ig = 1, ngrid
    4705       zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg
    4706     END DO
    4707   END DO
    4708   DO ig = 1, ngrid
    4709     zlev(ig, 1) = 0.
    4710     zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg
    4711   END DO
    4712   DO l = 1, nlay
    4713     DO ig = 1, ngrid
    4714       zlay(ig, l) = pphi(ig, l)/rg
    4715     END DO
    4716   END DO
    4717 
    4718   ! PRINT*,'2 OK convect8'
    4719   ! -----------------------------------------------------------------------
    4720   ! Calcul des densites
    4721   ! -----------------------------------------------------------------------
    4722 
    4723   DO l = 1, nlay
    4724     DO ig = 1, ngrid
    4725       rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*zh(ig,l))
    4726     END DO
    4727   END DO
    4728 
    4729   DO l = 2, nlay
    4730     DO ig = 1, ngrid
    4731       rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1))
    4732     END DO
    4733   END DO
    4734 
    4735   DO k = 1, nlay
    4736     DO l = 1, nlay + 1
    4737       DO ig = 1, ngrid
    4738         wa(ig, k, l) = 0.
    4739       END DO
    4740     END DO
    4741   END DO
    4742 
    4743   ! PRINT*,'3 OK convect8'
    4744   ! ------------------------------------------------------------------
    4745   ! Calcul de w2, quarre de w a partir de la cape
    4746   ! a partir de w2, on calcule wa, vitesse de l'ascendance
    4747 
    4748   ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
    4749   ! w2 est stoke dans wa
    4750 
    4751   ! ATTENTION: dans convect8, on n'utilise le calcule des wa
    4752   ! independants par couches que pour calculer l'entrainement
    4753   ! a la base et la hauteur max de l'ascendance.
    4754 
    4755   ! Indicages:
    4756   ! l'ascendance provenant du niveau k traverse l'interface l avec
    4757   ! une vitesse wa(k,l).
    4758 
    4759   ! --------------------
    4760 
    4761   ! + + + + + + + + + +
    4762 
    4763   ! wa(k,l)   ----       --------------------    l
    4764   ! /\
    4765   ! /||\       + + + + + + + + + +
    4766   ! ||
    4767   ! ||        --------------------
    4768   ! ||
    4769   ! ||        + + + + + + + + + +
    4770   ! ||
    4771   ! ||        --------------------
    4772   ! ||__
    4773   ! |___      + + + + + + + + + +     k
    4774 
    4775   ! --------------------
    4776 
    4777 
    4778 
    4779   ! ------------------------------------------------------------------
    4780 
    4781   ! CR: ponderation entrainement des couches instables
    4782   ! def des entr_star tels que entr=f*entr_star
    4783   DO l = 1, klev
    4784     DO ig = 1, ngrid
    4785       entr_star(ig, l) = 0.
    4786     END DO
    4787   END DO
    4788   ! determination de la longueur de la couche d entrainement
    4789   DO ig = 1, ngrid
    4790     lentr(ig) = 1
    4791   END DO
    4792 
    4793   ! on ne considere que les premieres couches instables
    4794   DO k = nlay - 2, 1, -1
    4795     DO ig = 1, ngrid
    4796       IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN
    4797         lentr(ig) = k
    4798       END IF
    4799     END DO
    4800   END DO
    4801 
    4802   ! determination du lmin: couche d ou provient le thermique
    4803   DO ig = 1, ngrid
    4804     lmin(ig) = 1
    4805   END DO
    4806   DO ig = 1, ngrid
    4807     DO l = nlay, 2, -1
    4808       IF (ztv(ig,l-1)>ztv(ig,l)) THEN
    4809         lmin(ig) = l - 1
    4810       END IF
    4811     END DO
    4812   END DO
    4813 
    4814   ! definition de l'entrainement des couches
    4815   DO l = 1, klev - 1
    4816     DO ig = 1, ngrid
    4817       IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN
    4818         entr_star(ig, l) = (ztv(ig,l)-ztv(ig,l+1))** & ! s
    4819                                                        ! (zlev(ig,l+1)-zlev(ig,l))
    4820           sqrt(zlev(ig,l+1))
    4821       END IF
    4822     END DO
    4823   END DO
    4824   ! pas de thermique si couche 1 stable
    4825   DO ig = 1, ngrid
    4826     IF (lmin(ig)>1) THEN
    4827       DO l = 1, klev
    4828         entr_star(ig, l) = 0.
    4829       END DO
    4830     END IF
    4831   END DO
    4832   ! calcul de l entrainement total
    4833   DO ig = 1, ngrid
    4834     entr_star_tot(ig) = 0.
    4835   END DO
    4836   DO ig = 1, ngrid
    4837     DO k = 1, klev
    4838       entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k)
    4839     END DO
    4840   END DO
    4841 
    4842   ! PRINT*,'fin calcul entr_star'
    4843   DO k = 1, klev
    4844     DO ig = 1, ngrid
    4845       ztva(ig, k) = ztv(ig, k)
    4846     END DO
    4847   END DO
    4848   ! RC
    4849   ! PRINT*,'7 OK convect8'
    4850   DO k = 1, klev + 1
    4851     DO ig = 1, ngrid
    4852       zw2(ig, k) = 0.
    4853       fmc(ig, k) = 0.
    4854       ! CR
    4855       f_star(ig, k) = 0.
    4856       ! RC
    4857       larg_cons(ig, k) = 0.
    4858       larg_detr(ig, k) = 0.
    4859       wa_moy(ig, k) = 0.
    4860     END DO
    4861   END DO
    4862 
    4863   ! PRINT*,'8 OK convect8'
    4864   DO ig = 1, ngrid
    4865     linter(ig) = 1.
    4866     lmaxa(ig) = 1
    4867     lmix(ig) = 1
    4868     wmaxa(ig) = 0.
    4869   END DO
    4870 
    4871   ! CR:
    4872   DO l = 1, nlay - 2
    4873     DO ig = 1, ngrid
    4874       IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. &
    4875           zw2(ig,l)<1E-10) THEN
    4876         f_star(ig, l+1) = entr_star(ig, l)
    4877         ! test:calcul de dteta
    4878         zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* &
    4879           (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l))
    4880         larg_detr(ig, l) = 0.
    4881       ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, &
    4882           l)>1.E-10)) THEN
    4883         f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l)
    4884         ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)*ztv(ig,l))/ &
    4885           f_star(ig, l+1)
    4886         zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + &
    4887           2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l))
    4888       END IF
    4889       ! determination de zmax continu par interpolation lineaire
    4890       IF (zw2(ig,l+1)<0.) THEN
     4954        ! Nouvelle fermeture
     4955        f(ig) = wmax(ig) / (max(500., zmax(ig)) * r_aspect * entr_star2(ig)) * &
     4956                entr_star_tot(ig)
    48914957        ! test
    4892         IF (abs(zw2(ig,l+1)-zw2(ig,l))<1E-10) THEN
    4893           ! PRINT*,'pb linter'
    4894         END IF
    4895         linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( &
    4896           ig,l))
    4897         zw2(ig, l+1) = 0.
    4898         lmaxa(ig) = l
    4899       ELSE
    4900         IF (zw2(ig,l+1)<0.) THEN
    4901           ! PRINT*,'pb1 zw2<0'
    4902         END IF
    4903         wa_moy(ig, l+1) = sqrt(zw2(ig,l+1))
    4904       END IF
    4905       IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN
    4906         ! lmix est le niveau de la couche ou w (wa_moy) est maximum
    4907         lmix(ig) = l + 1
    4908         wmaxa(ig) = wa_moy(ig, l+1)
    4909       END IF
    4910     END DO
    4911   END DO
    4912   ! PRINT*,'fin calcul zw2'
    4913 
    4914   ! Calcul de la couche correspondant a la hauteur du thermique
    4915   DO ig = 1, ngrid
    4916     lmax(ig) = lentr(ig)
    4917   END DO
    4918   DO ig = 1, ngrid
    4919     DO l = nlay, lentr(ig) + 1, -1
    4920       IF (zw2(ig,l)<=1.E-10) THEN
    4921         lmax(ig) = l - 1
    4922       END IF
    4923     END DO
    4924   END DO
    4925   ! pas de thermique si couche 1 stable
    4926   DO ig = 1, ngrid
    4927     IF (lmin(ig)>1) THEN
    4928       lmax(ig) = 1
    4929       lmin(ig) = 1
    4930     END IF
    4931   END DO
    4932 
    4933   ! Determination de zw2 max
    4934   DO ig = 1, ngrid
    4935     wmax(ig) = 0.
    4936   END DO
    4937 
    4938   DO l = 1, nlay
    4939     DO ig = 1, ngrid
    4940       IF (l<=lmax(ig)) THEN
    4941         IF (zw2(ig,l)<0.) THEN
    4942           ! PRINT*,'pb2 zw2<0'
    4943         END IF
    4944         zw2(ig, l) = sqrt(zw2(ig,l))
    4945         wmax(ig) = max(wmax(ig), zw2(ig,l))
    4946       ELSE
    4947         zw2(ig, l) = 0.
    4948       END IF
    4949     END DO
    4950   END DO
    4951 
    4952   ! Longueur caracteristique correspondant a la hauteur des thermiques.
    4953   DO ig = 1, ngrid
    4954     zmax(ig) = 0.
    4955     zlevinter(ig) = zlev(ig, 1)
    4956   END DO
    4957   DO ig = 1, ngrid
    4958     ! calcul de zlevinter
    4959     zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + &
    4960       zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
    4961     zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig)))
    4962   END DO
    4963 
    4964   ! PRINT*,'avant fermeture'
    4965   ! Fermeture,determination de f
    4966   DO ig = 1, ngrid
    4967     entr_star2(ig) = 0.
    4968   END DO
    4969   DO ig = 1, ngrid
    4970     IF (entr_star_tot(ig)<1.E-10) THEN
    4971       f(ig) = 0.
    4972     ELSE
    4973       DO k = lmin(ig), lentr(ig)
    4974         entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( &
    4975           zlev(ig,k+1)-zlev(ig,k)))
    4976       END DO
    4977       ! Nouvelle fermeture
    4978       f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*entr_star2(ig))* &
    4979         entr_star_tot(ig)
    4980       ! test
    4981       ! if (first) THEN
    4982       ! f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
    4983       ! s             *wmax(ig))
    4984       ! END IF
    4985     END IF
    4986     ! f0(ig)=f(ig)
    4987     ! first=.TRUE.
    4988   END DO
    4989   ! PRINT*,'apres fermeture'
    4990 
    4991   ! Calcul de l'entrainement
    4992   DO k = 1, klev
    4993     DO ig = 1, ngrid
    4994       entr(ig, k) = f(ig)*entr_star(ig, k)
    4995     END DO
    4996   END DO
    4997   ! CR:test pour entrainer moins que la masse
    4998   DO ig = 1, ngrid
    4999     DO l = 1, lentr(ig)
    5000       IF ((entr(ig,l)*ptimestep)>(0.9*masse(ig,l))) THEN
    5001         entr(ig, l+1) = entr(ig, l+1) + entr(ig, l) - &
    5002           0.9*masse(ig, l)/ptimestep
    5003         entr(ig, l) = 0.9*masse(ig, l)/ptimestep
    5004       END IF
    5005     END DO
    5006   END DO
    5007   ! CR: fin test
    5008   ! Calcul des flux
    5009   DO ig = 1, ngrid
    5010     DO l = 1, lmax(ig) - 1
    5011       fmc(ig, l+1) = fmc(ig, l) + entr(ig, l)
    5012     END DO
    5013   END DO
    5014 
    5015   ! RC
    5016 
    5017 
    5018   ! PRINT*,'9 OK convect8'
    5019   ! PRINT*,'WA1 ',wa_moy
    5020 
    5021   ! determination de l'indice du debut de la mixed layer ou w decroit
    5022 
    5023   ! calcul de la largeur de chaque ascendance dans le cas conservatif.
    5024   ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
    5025   ! d'une couche est égale à la hauteur de la couche alimentante.
    5026   ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
    5027   ! de la vitesse d'entrainement horizontal dans la couche alimentante.
    5028 
    5029   DO l = 2, nlay
    5030     DO ig = 1, ngrid
    5031       IF (l<=lmaxa(ig)) THEN
    5032         zw = max(wa_moy(ig,l), 1.E-10)
    5033         larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw)
    5034       END IF
    5035     END DO
    5036   END DO
    5037 
    5038   DO l = 2, nlay
    5039     DO ig = 1, ngrid
    5040       IF (l<=lmaxa(ig)) THEN
    5041         ! if (idetr.EQ.0) THEN
    5042         ! cette option est finalement en dur.
    5043         IF ((l_mix*zlev(ig,l))<0.) THEN
    5044           ! PRINT*,'pb l_mix*zlev<0'
    5045         END IF
    5046         ! CR: test: nouvelle def de lambda
    5047         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    5048         IF (zw2(ig,l)>1.E-10) THEN
    5049           larg_detr(ig, l) = sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
    5050         ELSE
    5051           larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l))
    5052         END IF
    5053         ! RC
    5054         ! ELSE IF (idetr.EQ.1) THEN
    5055         ! larg_detr(ig,l)=larg_cons(ig,l)
    5056         ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
    5057         ! ELSE IF (idetr.EQ.2) THEN
    5058         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    5059         ! s            *sqrt(wa_moy(ig,l))
    5060         ! ELSE IF (idetr.EQ.4) THEN
    5061         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    5062         ! s            *wa_moy(ig,l)
     4958        ! if (first) THEN
     4959        ! f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
     4960        ! s             *wmax(ig))
    50634961        ! END IF
    50644962      END IF
    5065     END DO
    5066   END DO
    5067 
    5068   ! PRINT*,'10 OK convect8'
    5069   ! PRINT*,'WA2 ',wa_moy
    5070   ! calcul de la fraction de la maille concernée par l'ascendance en tenant
    5071   ! compte de l'epluchage du thermique.
    5072 
    5073   ! CR def de  zmix continu (profil parabolique des vitesses)
    5074   DO ig = 1, ngrid
    5075     IF (lmix(ig)>1.) THEN
     4963      ! f0(ig)=f(ig)
     4964      ! first=.TRUE.
     4965    END DO
     4966    ! PRINT*,'apres fermeture'
     4967
     4968    ! Calcul de l'entrainement
     4969    DO k = 1, klev
     4970      DO ig = 1, ngrid
     4971        entr(ig, k) = f(ig) * entr_star(ig, k)
     4972      END DO
     4973    END DO
     4974    ! CR:test pour entrainer moins que la masse
     4975    DO ig = 1, ngrid
     4976      DO l = 1, lentr(ig)
     4977        IF ((entr(ig, l) * ptimestep)>(0.9 * masse(ig, l))) THEN
     4978          entr(ig, l + 1) = entr(ig, l + 1) + entr(ig, l) - &
     4979                  0.9 * masse(ig, l) / ptimestep
     4980          entr(ig, l) = 0.9 * masse(ig, l) / ptimestep
     4981        END IF
     4982      END DO
     4983    END DO
     4984    ! CR: fin test
     4985    ! Calcul des flux
     4986    DO ig = 1, ngrid
     4987      DO l = 1, lmax(ig) - 1
     4988        fmc(ig, l + 1) = fmc(ig, l) + entr(ig, l)
     4989      END DO
     4990    END DO
     4991
     4992    ! RC
     4993
     4994
     4995    ! PRINT*,'9 OK convect8'
     4996    ! PRINT*,'WA1 ',wa_moy
     4997
     4998    ! determination de l'indice du debut de la mixed layer ou w decroit
     4999
     5000    ! calcul de la largeur de chaque ascendance dans le cas conservatif.
     5001    ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
     5002    ! d'une couche est égale à la hauteur de la couche alimentante.
     5003    ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
     5004    ! de la vitesse d'entrainement horizontal dans la couche alimentante.
     5005
     5006    DO l = 2, nlay
     5007      DO ig = 1, ngrid
     5008        IF (l<=lmaxa(ig)) THEN
     5009          zw = max(wa_moy(ig, l), 1.E-10)
     5010          larg_cons(ig, l) = zmax(ig) * r_aspect * fmc(ig, l) / (rhobarz(ig, l) * zw)
     5011        END IF
     5012      END DO
     5013    END DO
     5014
     5015    DO l = 2, nlay
     5016      DO ig = 1, ngrid
     5017        IF (l<=lmaxa(ig)) THEN
     5018          ! if (idetr.EQ.0) THEN
     5019          ! cette option est finalement en dur.
     5020          IF ((l_mix * zlev(ig, l))<0.) THEN
     5021            ! PRINT*,'pb l_mix*zlev<0'
     5022          END IF
     5023          ! CR: test: nouvelle def de lambda
     5024          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     5025          IF (zw2(ig, l)>1.E-10) THEN
     5026            larg_detr(ig, l) = sqrt((l_mix / zw2(ig, l)) * zlev(ig, l))
     5027          ELSE
     5028            larg_detr(ig, l) = sqrt(l_mix * zlev(ig, l))
     5029          END IF
     5030          ! RC
     5031          ! ELSE IF (idetr.EQ.1) THEN
     5032          ! larg_detr(ig,l)=larg_cons(ig,l)
     5033          ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
     5034          ! ELSE IF (idetr.EQ.2) THEN
     5035          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     5036          ! s            *sqrt(wa_moy(ig,l))
     5037          ! ELSE IF (idetr.EQ.4) THEN
     5038          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     5039          ! s            *wa_moy(ig,l)
     5040          ! END IF
     5041        END IF
     5042      END DO
     5043    END DO
     5044
     5045    ! PRINT*,'10 OK convect8'
     5046    ! PRINT*,'WA2 ',wa_moy
     5047    ! calcul de la fraction de la maille concernée par l'ascendance en tenant
     5048    ! compte de l'epluchage du thermique.
     5049
     5050    ! CR def de  zmix continu (profil parabolique des vitesses)
     5051    DO ig = 1, ngrid
     5052      IF (lmix(ig)>1.) THEN
     5053        ! test
     5054        IF (((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig))) - &
     5055                (zlev(ig, lmix(ig) + 1))) - (zw2(ig, lmix(ig)) - &
     5056                zw2(ig, lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1)) - &
     5057                (zlev(ig, lmix(ig)))))>1E-10) THEN
     5058
     5059          zmix(ig) = ((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig)) &
     5060                  )**2 - (zlev(ig, lmix(ig) + 1))**2) - (zw2(ig, lmix(ig)) - zw2(ig, &
     5061                  lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1))**2 - (zlev(ig, lmix(ig)))**2)) / &
     5062                  (2. * ((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig))) - &
     5063                          (zlev(ig, lmix(ig) + 1))) - (zw2(ig, lmix(ig)) - &
     5064                          zw2(ig, lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1)) - (zlev(ig, lmix(ig))))))
     5065        ELSE
     5066          zmix(ig) = zlev(ig, lmix(ig))
     5067          ! PRINT*,'pb zmix'
     5068        END IF
     5069      ELSE
     5070        zmix(ig) = 0.
     5071      END IF
    50765072      ! test
    5077       IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- &
    5078           (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- &
    5079           zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- &
    5080           (zlev(ig,lmix(ig)))))>1E-10) THEN
    5081 
    5082         zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) &
    5083           )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, &
    5084           lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ &
    5085           (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- &
    5086           (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- &
    5087           zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
    5088       ELSE
    5089         zmix(ig) = zlev(ig, lmix(ig))
    5090         ! PRINT*,'pb zmix'
     5073      IF ((zmax(ig) - zmix(ig))<0.) THEN
     5074        zmix(ig) = 0.99 * zmax(ig)
     5075        ! PRINT*,'pb zmix>zmax'
    50915076      END IF
     5077    END DO
     5078
     5079    ! calcul du nouveau lmix correspondant
     5080    DO ig = 1, ngrid
     5081      DO l = 1, klev
     5082        IF (zmix(ig)>=zlev(ig, l) .AND. zmix(ig)<zlev(ig, l + 1)) THEN
     5083          lmix(ig) = l
     5084        END IF
     5085      END DO
     5086    END DO
     5087
     5088    DO l = 2, nlay
     5089      DO ig = 1, ngrid
     5090        IF (larg_cons(ig, l)>1.) THEN
     5091          ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
     5092          fraca(ig, l) = (larg_cons(ig, l) - larg_detr(ig, l)) / (r_aspect * zmax(ig))
     5093          ! test
     5094          fraca(ig, l) = max(fraca(ig, l), 0.)
     5095          fraca(ig, l) = min(fraca(ig, l), 0.5)
     5096          fracd(ig, l) = 1. - fraca(ig, l)
     5097          fracc(ig, l) = larg_cons(ig, l) / (r_aspect * zmax(ig))
     5098        ELSE
     5099          ! wa_moy(ig,l)=0.
     5100          fraca(ig, l) = 0.
     5101          fracc(ig, l) = 0.
     5102          fracd(ig, l) = 1.
     5103        END IF
     5104      END DO
     5105    END DO
     5106    ! CR: calcul de fracazmix
     5107    DO ig = 1, ngrid
     5108      fracazmix(ig) = (fraca(ig, lmix(ig) + 1) - fraca(ig, lmix(ig))) / &
     5109              (zlev(ig, lmix(ig) + 1) - zlev(ig, lmix(ig))) * zmix(ig) + &
     5110              fraca(ig, lmix(ig)) - zlev(ig, lmix(ig)) * (fraca(ig, lmix(ig) + 1) - fraca(ig &
     5111              , lmix(ig))) / (zlev(ig, lmix(ig) + 1) - zlev(ig, lmix(ig)))
     5112    END DO
     5113
     5114    DO l = 2, nlay
     5115      DO ig = 1, ngrid
     5116        IF (larg_cons(ig, l)>1.) THEN
     5117          IF (l>lmix(ig)) THEN
     5118            ! test
     5119            IF (zmax(ig) - zmix(ig)<1.E-10) THEN
     5120              ! PRINT*,'pb xxx'
     5121              xxx(ig, l) = (lmaxa(ig) + 1. - l) / (lmaxa(ig) + 1. - lmix(ig))
     5122            ELSE
     5123              xxx(ig, l) = (zmax(ig) - zlev(ig, l)) / (zmax(ig) - zmix(ig))
     5124            END IF
     5125            IF (idetr==0) THEN
     5126              fraca(ig, l) = fracazmix(ig)
     5127            ELSE IF (idetr==1) THEN
     5128              fraca(ig, l) = fracazmix(ig) * xxx(ig, l)
     5129            ELSE IF (idetr==2) THEN
     5130              fraca(ig, l) = fracazmix(ig) * (1. - (1. - xxx(ig, l))**2)
     5131            ELSE
     5132              fraca(ig, l) = fracazmix(ig) * xxx(ig, l)**2
     5133            END IF
     5134            ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
     5135            fraca(ig, l) = max(fraca(ig, l), 0.)
     5136            fraca(ig, l) = min(fraca(ig, l), 0.5)
     5137            fracd(ig, l) = 1. - fraca(ig, l)
     5138            fracc(ig, l) = larg_cons(ig, l) / (r_aspect * zmax(ig))
     5139          END IF
     5140        END IF
     5141      END DO
     5142    END DO
     5143
     5144    ! PRINT*,'fin calcul fraca'
     5145    ! PRINT*,'11 OK convect8'
     5146    ! PRINT*,'Ea3 ',wa_moy
     5147    ! ------------------------------------------------------------------
     5148    ! Calcul de fracd, wd
     5149    ! somme wa - wd = 0
     5150    ! ------------------------------------------------------------------
     5151
     5152    DO ig = 1, ngrid
     5153      fm(ig, 1) = 0.
     5154      fm(ig, nlay + 1) = 0.
     5155    END DO
     5156
     5157    DO l = 2, nlay
     5158      DO ig = 1, ngrid
     5159        fm(ig, l) = fraca(ig, l) * wa_moy(ig, l) * rhobarz(ig, l)
     5160        ! CR:test
     5161        IF (entr(ig, l - 1)<1E-10 .AND. fm(ig, l)>fm(ig, l - 1) .AND. l>lmix(ig)) THEN
     5162          fm(ig, l) = fm(ig, l - 1)
     5163          ! WRITE(1,*)'ajustement fm, l',l
     5164        END IF
     5165        ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
     5166        ! RC
     5167      END DO
     5168      DO ig = 1, ngrid
     5169        IF (fracd(ig, l)<0.1) THEN
     5170          abort_message = 'fracd trop petit'
     5171          CALL abort_physic(modname, abort_message, 1)
     5172        ELSE
     5173          ! vitesse descendante "diagnostique"
     5174          wd(ig, l) = fm(ig, l) / (fracd(ig, l) * rhobarz(ig, l))
     5175        END IF
     5176      END DO
     5177    END DO
     5178
     5179    DO l = 1, nlay
     5180      DO ig = 1, ngrid
     5181        ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
     5182        masse(ig, l) = (pplev(ig, l) - pplev(ig, l + 1)) / rg
     5183      END DO
     5184    END DO
     5185
     5186    ! PRINT*,'12 OK convect8'
     5187    ! PRINT*,'WA4 ',wa_moy
     5188    ! c------------------------------------------------------------------
     5189    ! calcul du transport vertical
     5190    ! ------------------------------------------------------------------
     5191
     5192    GO TO 4444
     5193    ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
     5194    DO l = 2, nlay - 1
     5195      DO ig = 1, ngrid
     5196        IF (fm(ig, l + 1) * ptimestep>masse(ig, l) .AND. fm(ig, l + 1) * ptimestep>masse(&
     5197                ig, l + 1)) THEN
     5198          ! PRINT*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
     5199          ! s         ,fm(ig,l+1)*ptimestep
     5200          ! s         ,'   M=',masse(ig,l),masse(ig,l+1)
     5201        END IF
     5202      END DO
     5203    END DO
     5204
     5205    DO l = 1, nlay
     5206      DO ig = 1, ngrid
     5207        IF (entr(ig, l) * ptimestep>masse(ig, l)) THEN
     5208          ! PRINT*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
     5209          ! s         ,entr(ig,l)*ptimestep
     5210          ! s         ,'   M=',masse(ig,l)
     5211        END IF
     5212      END DO
     5213    END DO
     5214
     5215    DO l = 1, nlay
     5216      DO ig = 1, ngrid
     5217        IF (.NOT. fm(ig, l)>=0. .OR. .NOT. fm(ig, l)<=10.) THEN
     5218          ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
     5219          ! s         ,'   FM=',fm(ig,l)
     5220        END IF
     5221        IF (.NOT. masse(ig, l)>=1.E-10 .OR. .NOT. masse(ig, l)<=1.E4) THEN
     5222          ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
     5223          ! s         ,'   M=',masse(ig,l)
     5224          ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
     5225          ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
     5226          ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
     5227          ! s                ,zlev(ig,l+1),zlev(ig,l)
     5228          ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
     5229          ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
     5230        END IF
     5231        IF (.NOT. entr(ig, l)>=0. .OR. .NOT. entr(ig, l)<=10.) THEN
     5232          ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
     5233          ! s         ,'   E=',entr(ig,l)
     5234        END IF
     5235      END DO
     5236    END DO
     5237
     5238    4444 CONTINUE
     5239
     5240    ! CR:redefinition du entr
     5241    DO l = 1, nlay
     5242      DO ig = 1, ngrid
     5243        detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l + 1)
     5244        IF (detr(ig, l)<0.) THEN
     5245          entr(ig, l) = entr(ig, l) - detr(ig, l)
     5246          detr(ig, l) = 0.
     5247          ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
     5248        END IF
     5249      END DO
     5250    END DO
     5251    ! RC
     5252    IF (w2di==1) THEN
     5253      fm0 = fm0 + ptimestep * (fm - fm0) / tho
     5254      entr0 = entr0 + ptimestep * (entr - entr0) / tho
    50925255    ELSE
    5093       zmix(ig) = 0.
     5256      fm0 = fm
     5257      entr0 = entr
    50945258    END IF
    5095     ! test
    5096     IF ((zmax(ig)-zmix(ig))<0.) THEN
    5097       zmix(ig) = 0.99*zmax(ig)
    5098       ! PRINT*,'pb zmix>zmax'
     5259
     5260    IF (1==1) THEN
     5261      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, &
     5262              zha)
     5263      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, &
     5264              zoa)
     5265    ELSE
     5266      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
     5267              zdhadj, zha)
     5268      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
     5269              pdoadj, zoa)
    50995270    END IF
    5100   END DO
    5101 
    5102   ! calcul du nouveau lmix correspondant
    5103   DO ig = 1, ngrid
    5104     DO l = 1, klev
    5105       IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)<zlev(ig,l+1)) THEN
    5106         lmix(ig) = l
    5107       END IF
    5108     END DO
    5109   END DO
    5110 
    5111   DO l = 2, nlay
    5112     DO ig = 1, ngrid
    5113       IF (larg_cons(ig,l)>1.) THEN
    5114         ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
    5115         fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig))
    5116         ! test
    5117         fraca(ig, l) = max(fraca(ig,l), 0.)
    5118         fraca(ig, l) = min(fraca(ig,l), 0.5)
    5119         fracd(ig, l) = 1. - fraca(ig, l)
    5120         fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig))
    5121       ELSE
    5122         ! wa_moy(ig,l)=0.
    5123         fraca(ig, l) = 0.
    5124         fracc(ig, l) = 0.
    5125         fracd(ig, l) = 1.
    5126       END IF
    5127     END DO
    5128   END DO
    5129   ! CR: calcul de fracazmix
    5130   DO ig = 1, ngrid
    5131     fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ &
    5132       (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + &
    5133       fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig &
    5134       ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
    5135   END DO
    5136 
    5137   DO l = 2, nlay
    5138     DO ig = 1, ngrid
    5139       IF (larg_cons(ig,l)>1.) THEN
    5140         IF (l>lmix(ig)) THEN
    5141           ! test
    5142           IF (zmax(ig)-zmix(ig)<1.E-10) THEN
    5143             ! PRINT*,'pb xxx'
    5144             xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
    5145           ELSE
    5146             xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
    5147           END IF
    5148           IF (idetr==0) THEN
    5149             fraca(ig, l) = fracazmix(ig)
    5150           ELSE IF (idetr==1) THEN
    5151             fraca(ig, l) = fracazmix(ig)*xxx(ig, l)
    5152           ELSE IF (idetr==2) THEN
    5153             fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
    5154           ELSE
    5155             fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2
    5156           END IF
    5157           ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
    5158           fraca(ig, l) = max(fraca(ig,l), 0.)
    5159           fraca(ig, l) = min(fraca(ig,l), 0.5)
    5160           fracd(ig, l) = 1. - fraca(ig, l)
    5161           fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig))
    5162         END IF
    5163       END IF
    5164     END DO
    5165   END DO
    5166 
    5167   ! PRINT*,'fin calcul fraca'
    5168   ! PRINT*,'11 OK convect8'
    5169   ! PRINT*,'Ea3 ',wa_moy
    5170   ! ------------------------------------------------------------------
    5171   ! Calcul de fracd, wd
    5172   ! somme wa - wd = 0
    5173   ! ------------------------------------------------------------------
    5174 
    5175 
    5176   DO ig = 1, ngrid
    5177     fm(ig, 1) = 0.
    5178     fm(ig, nlay+1) = 0.
    5179   END DO
    5180 
    5181   DO l = 2, nlay
    5182     DO ig = 1, ngrid
    5183       fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l)
    5184       ! CR:test
    5185       IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN
    5186         fm(ig, l) = fm(ig, l-1)
    5187         ! WRITE(1,*)'ajustement fm, l',l
    5188       END IF
    5189       ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
    5190       ! RC
    5191     END DO
    5192     DO ig = 1, ngrid
    5193       IF (fracd(ig,l)<0.1) THEN
    5194         abort_message = 'fracd trop petit'
    5195         CALL abort_physic(modname, abort_message, 1)
    5196       ELSE
    5197         ! vitesse descendante "diagnostique"
    5198         wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l))
    5199       END IF
    5200     END DO
    5201   END DO
    5202 
    5203   DO l = 1, nlay
    5204     DO ig = 1, ngrid
    5205       ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    5206       masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg
    5207     END DO
    5208   END DO
    5209 
    5210   ! PRINT*,'12 OK convect8'
    5211   ! PRINT*,'WA4 ',wa_moy
    5212   ! c------------------------------------------------------------------
    5213   ! calcul du transport vertical
    5214   ! ------------------------------------------------------------------
    5215 
    5216   GO TO 4444
    5217   ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
    5218   DO l = 2, nlay - 1
    5219     DO ig = 1, ngrid
    5220       IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( &
    5221           ig,l+1)) THEN
    5222         ! PRINT*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
    5223         ! s         ,fm(ig,l+1)*ptimestep
    5224         ! s         ,'   M=',masse(ig,l),masse(ig,l+1)
    5225       END IF
    5226     END DO
    5227   END DO
    5228 
    5229   DO l = 1, nlay
    5230     DO ig = 1, ngrid
    5231       IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN
    5232         ! PRINT*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
    5233         ! s         ,entr(ig,l)*ptimestep
    5234         ! s         ,'   M=',masse(ig,l)
    5235       END IF
    5236     END DO
    5237   END DO
    5238 
    5239   DO l = 1, nlay
    5240     DO ig = 1, ngrid
    5241       IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN
    5242         ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
    5243         ! s         ,'   FM=',fm(ig,l)
    5244       END IF
    5245       IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN
    5246         ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
    5247         ! s         ,'   M=',masse(ig,l)
    5248         ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
    5249         ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
    5250         ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
    5251         ! s                ,zlev(ig,l+1),zlev(ig,l)
    5252         ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
    5253         ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
    5254       END IF
    5255       IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN
    5256         ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
    5257         ! s         ,'   E=',entr(ig,l)
    5258       END IF
    5259     END DO
    5260   END DO
    5261 
    5262 4444 CONTINUE
    5263 
    5264   ! CR:redefinition du entr
    5265   DO l = 1, nlay
    5266     DO ig = 1, ngrid
    5267       detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1)
    5268       IF (detr(ig,l)<0.) THEN
    5269         entr(ig, l) = entr(ig, l) - detr(ig, l)
    5270         detr(ig, l) = 0.
    5271         ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
    5272       END IF
    5273     END DO
    5274   END DO
    5275   ! RC
    5276   IF (w2di==1) THEN
    5277     fm0 = fm0 + ptimestep*(fm-fm0)/tho
    5278     entr0 = entr0 + ptimestep*(entr-entr0)/tho
    5279   ELSE
    5280     fm0 = fm
    5281     entr0 = entr
    5282   END IF
    5283 
    5284   IF (1==1) THEN
    5285     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, &
    5286       zha)
    5287     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, &
    5288       zoa)
    5289   ELSE
    5290     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
    5291       zdhadj, zha)
    5292     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
    5293       pdoadj, zoa)
    5294   END IF
    5295 
    5296   IF (1==0) THEN
    5297     CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
    5298       zu, zv, pduadj, pdvadj, zua, zva)
    5299   ELSE
    5300     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
    5301       zua)
    5302     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
    5303       zva)
    5304   END IF
    5305 
    5306   DO l = 1, nlay
    5307     DO ig = 1, ngrid
    5308       zf = 0.5*(fracc(ig,l)+fracc(ig,l+1))
    5309       zf2 = zf/(1.-zf)
    5310       thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2
    5311       wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
    5312     END DO
    5313   END DO
    5314 
    5315 
    5316 
    5317   ! PRINT*,'13 OK convect8'
    5318   ! PRINT*,'WA5 ',wa_moy
    5319   DO l = 1, nlay
    5320     DO ig = 1, ngrid
    5321       pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l)
    5322     END DO
    5323   END DO
    5324 
    5325 
    5326   ! do l=1,nlay
    5327   ! do ig=1,ngrid
    5328   ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
    5329   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    5330   ! s         ,'   pdtadj=',pdtadj(ig,l)
    5331   ! END IF
    5332   ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
    5333   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    5334   ! s         ,'   pdoadj=',pdoadj(ig,l)
    5335   ! END IF
    5336   ! enddo
    5337   ! enddo
    5338 
    5339   ! PRINT*,'14 OK convect8'
    5340   ! ------------------------------------------------------------------
    5341   ! Calculs pour les sorties
    5342   ! ------------------------------------------------------------------
    5343 
    5344 
    5345 END SUBROUTINE thermcell_sec
    5346 
    5347 SUBROUTINE calcul_sec(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, pu, &
    5348     pv, pt, po, zmax, wmax, zw2, lmix & ! s
    5349                                         ! ,pu_therm,pv_therm
    5350     , r_aspect, l_mix, w2di, tho)
    5351 
    5352   USE dimphy
    5353   IMPLICIT NONE
    5354 
    5355   ! =======================================================================
    5356 
    5357   ! Calcul du transport verticale dans la couche limite en presence
    5358   ! de "thermiques" explicitement representes
    5359 
    5360   ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
    5361 
    5362   ! le thermique est supposé homogène et dissipé par mélange avec
    5363   ! son environnement. la longueur l_mix contrôle l'efficacité du
    5364   ! mélange
    5365 
    5366   ! Le calcul du transport des différentes espèces se fait en prenant
    5367   ! en compte:
    5368   ! 1. un flux de masse montant
    5369   ! 2. un flux de masse descendant
    5370   ! 3. un entrainement
    5371   ! 4. un detrainement
    5372 
    5373   ! =======================================================================
    5374 
    5375   ! -----------------------------------------------------------------------
    5376   ! declarations:
    5377   ! -------------
    5378 
    5379   include "YOMCST.h"
    5380 
    5381   ! arguments:
    5382   ! ----------
    5383 
    5384   INTEGER ngrid, nlay, w2di
    5385   REAL tho
    5386   REAL ptimestep, l_mix, r_aspect
    5387   REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
    5388   REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
    5389   REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
    5390   REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
    5391   REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1)
    5392   REAL pphi(ngrid, nlay)
    5393 
    5394   INTEGER idetr
    5395   SAVE idetr
    5396   DATA idetr/3/
    5397   !$OMP THREADPRIVATE(idetr)
    5398   ! local:
    5399   ! ------
    5400 
    5401   INTEGER ig, k, l, lmaxa(klon), lmix(klon)
    5402   REAL zsortie1d(klon)
    5403   ! CR: on remplace lmax(klon,klev+1)
    5404   INTEGER lmax(klon), lmin(klon), lentr(klon)
    5405   REAL linter(klon)
    5406   REAL zmix(klon), fracazmix(klon)
    5407   ! RC
    5408   REAL zmax(klon), zw, zw2(klon, klev+1), ztva(klon, klev)
    5409 
    5410   REAL zlev(klon, klev+1), zlay(klon, klev)
    5411   REAL zh(klon, klev), zdhadj(klon, klev)
    5412   REAL ztv(klon, klev)
    5413   REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
    5414   REAL wh(klon, klev+1)
    5415   REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1)
    5416   REAL zla(klon, klev+1)
    5417   REAL zwa(klon, klev+1)
    5418   REAL zld(klon, klev+1)
    5419   ! real zwd(klon,klev+1)
    5420   REAL zsortie(klon, klev)
    5421   REAL zva(klon, klev)
    5422   REAL zua(klon, klev)
    5423   REAL zoa(klon, klev)
    5424 
    5425   REAL zha(klon, klev)
    5426   REAL wa_moy(klon, klev+1)
    5427   REAL fraca(klon, klev+1)
    5428   REAL fracc(klon, klev+1)
    5429   REAL zf, zf2
    5430   REAL thetath2(klon, klev), wth2(klon, klev)
    5431   ! common/comtherm/thetath2,wth2
    5432 
    5433   REAL count_time
    5434   ! integer isplit,nsplit
    5435   INTEGER isplit, nsplit, ialt
    5436   PARAMETER (nsplit=10)
    5437   DATA isplit/0/
    5438   SAVE isplit
    5439   !$OMP THREADPRIVATE(isplit)
    5440 
    5441   LOGICAL sorties
    5442   REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev)
    5443   REAL zpspsk(klon, klev)
    5444 
    5445   ! real wmax(klon,klev),wmaxa(klon)
    5446   REAL wmax(klon), wmaxa(klon)
    5447   REAL wa(klon, klev, klev+1)
    5448   REAL wd(klon, klev+1)
    5449   REAL larg_part(klon, klev, klev+1)
    5450   REAL fracd(klon, klev+1)
    5451   REAL xxx(klon, klev+1)
    5452   REAL larg_cons(klon, klev+1)
    5453   REAL larg_detr(klon, klev+1)
    5454   REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev)
    5455   REAL pu_therm(klon, klev), pv_therm(klon, klev)
    5456   REAL fm(klon, klev+1), entr(klon, klev)
    5457   REAL fmc(klon, klev+1)
    5458 
    5459   ! CR:nouvelles variables
    5460   REAL f_star(klon, klev+1), entr_star(klon, klev)
    5461   REAL entr_star_tot(klon), entr_star2(klon)
    5462   REAL zalim(klon)
    5463   INTEGER lalim(klon)
    5464   REAL norme(klon)
    5465   REAL f(klon), f0(klon)
    5466   REAL zlevinter(klon)
    5467   LOGICAL therm
    5468   LOGICAL first
    5469   DATA first/.FALSE./
    5470   SAVE first
    5471   !$OMP THREADPRIVATE(first)
    5472   ! RC
    5473 
    5474   CHARACTER *2 str2
    5475   CHARACTER *10 str10
    5476 
    5477   CHARACTER (LEN=20) :: modname = 'calcul_sec'
    5478   CHARACTER (LEN=80) :: abort_message
    5479 
    5480 
    5481   ! LOGICAL vtest(klon),down
    5482 
    5483   EXTERNAL scopy
    5484 
    5485   INTEGER ncorrec
    5486   SAVE ncorrec
    5487   DATA ncorrec/0/
    5488   !$OMP THREADPRIVATE(ncorrec)
    5489 
    5490 
    5491   ! -----------------------------------------------------------------------
    5492   ! initialisation:
    5493   ! ---------------
    5494 
    5495   sorties = .TRUE.
    5496   IF (ngrid/=klon) THEN
    5497     PRINT *
    5498     PRINT *, 'STOP dans convadj'
    5499     PRINT *, 'ngrid    =', ngrid
    5500     PRINT *, 'klon  =', klon
    5501   END IF
    5502 
    5503   ! -----------------------------------------------------------------------
    5504   ! incrementation eventuelle de tendances precedentes:
    5505   ! ---------------------------------------------------
    5506 
    5507   ! PRINT*,'0 OK convect8'
    5508 
    5509   DO l = 1, nlay
    5510     DO ig = 1, ngrid
    5511       zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa
    5512       zh(ig, l) = pt(ig, l)/zpspsk(ig, l)
    5513       zu(ig, l) = pu(ig, l)
    5514       zv(ig, l) = pv(ig, l)
    5515       zo(ig, l) = po(ig, l)
    5516       ztv(ig, l) = zh(ig, l)*(1.+0.61*zo(ig,l))
    5517     END DO
    5518   END DO
    5519 
    5520   ! PRINT*,'1 OK convect8'
    5521   ! --------------------
    5522 
    5523 
    5524   ! + + + + + + + + + + +
    5525 
    5526 
    5527   ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
    5528   ! wh,wt,wo ...
    5529 
    5530   ! + + + + + + + + + + +  zh,zu,zv,zo,rho
    5531 
    5532 
    5533   ! --------------------   zlev(1)
    5534   ! \\\\\\\\\\\\\\\\\\\\
    5535 
    5536 
    5537 
    5538   ! -----------------------------------------------------------------------
    5539   ! Calcul des altitudes des couches
    5540   ! -----------------------------------------------------------------------
    5541 
    5542   DO l = 2, nlay
    5543     DO ig = 1, ngrid
    5544       zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg
    5545     END DO
    5546   END DO
    5547   DO ig = 1, ngrid
    5548     zlev(ig, 1) = 0.
    5549     zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg
    5550   END DO
    5551   DO l = 1, nlay
    5552     DO ig = 1, ngrid
    5553       zlay(ig, l) = pphi(ig, l)/rg
    5554     END DO
    5555   END DO
    5556 
    5557   ! PRINT*,'2 OK convect8'
    5558   ! -----------------------------------------------------------------------
    5559   ! Calcul des densites
    5560   ! -----------------------------------------------------------------------
    5561 
    5562   DO l = 1, nlay
    5563     DO ig = 1, ngrid
    5564       rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*zh(ig,l))
    5565     END DO
    5566   END DO
    5567 
    5568   DO l = 2, nlay
    5569     DO ig = 1, ngrid
    5570       rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1))
    5571     END DO
    5572   END DO
    5573 
    5574   DO k = 1, nlay
    5575     DO l = 1, nlay + 1
    5576       DO ig = 1, ngrid
    5577         wa(ig, k, l) = 0.
    5578       END DO
    5579     END DO
    5580   END DO
    5581 
    5582   ! PRINT*,'3 OK convect8'
    5583   ! ------------------------------------------------------------------
    5584   ! Calcul de w2, quarre de w a partir de la cape
    5585   ! a partir de w2, on calcule wa, vitesse de l'ascendance
    5586 
    5587   ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
    5588   ! w2 est stoke dans wa
    5589 
    5590   ! ATTENTION: dans convect8, on n'utilise le calcule des wa
    5591   ! independants par couches que pour calculer l'entrainement
    5592   ! a la base et la hauteur max de l'ascendance.
    5593 
    5594   ! Indicages:
    5595   ! l'ascendance provenant du niveau k traverse l'interface l avec
    5596   ! une vitesse wa(k,l).
    5597 
    5598   ! --------------------
    5599 
    5600   ! + + + + + + + + + +
    5601 
    5602   ! wa(k,l)   ----       --------------------    l
    5603   ! /\
    5604   ! /||\       + + + + + + + + + +
    5605   ! ||
    5606   ! ||        --------------------
    5607   ! ||
    5608   ! ||        + + + + + + + + + +
    5609   ! ||
    5610   ! ||        --------------------
    5611   ! ||__
    5612   ! |___      + + + + + + + + + +     k
    5613 
    5614   ! --------------------
    5615 
    5616 
    5617 
    5618   ! ------------------------------------------------------------------
    5619 
    5620   ! CR: ponderation entrainement des couches instables
    5621   ! def des entr_star tels que entr=f*entr_star
    5622   DO l = 1, klev
    5623     DO ig = 1, ngrid
    5624       entr_star(ig, l) = 0.
    5625     END DO
    5626   END DO
    5627   ! determination de la longueur de la couche d entrainement
    5628   DO ig = 1, ngrid
    5629     lentr(ig) = 1
    5630   END DO
    5631 
    5632   ! on ne considere que les premieres couches instables
    5633   therm = .FALSE.
    5634   DO k = nlay - 2, 1, -1
    5635     DO ig = 1, ngrid
    5636       IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN
    5637         lentr(ig) = k + 1
    5638         therm = .TRUE.
    5639       END IF
    5640     END DO
    5641   END DO
    5642   ! limitation de la valeur du lentr
    5643   ! do ig=1,ngrid
    5644   ! lentr(ig)=min(5,lentr(ig))
    5645   ! enddo
    5646   ! determination du lmin: couche d ou provient le thermique
    5647   DO ig = 1, ngrid
    5648     lmin(ig) = 1
    5649   END DO
    5650   DO ig = 1, ngrid
    5651     DO l = nlay, 2, -1
    5652       IF (ztv(ig,l-1)>ztv(ig,l)) THEN
    5653         lmin(ig) = l - 1
    5654       END IF
    5655     END DO
    5656   END DO
    5657   ! initialisations
    5658   DO ig = 1, ngrid
    5659     zalim(ig) = 0.
    5660     norme(ig) = 0.
    5661     lalim(ig) = 1
    5662   END DO
    5663   DO k = 1, klev - 1
    5664     DO ig = 1, ngrid
    5665       zalim(ig) = zalim(ig) + zlev(ig, k)*max(0., (ztv(ig,k)-ztv(ig, &
    5666         k+1))/(zlev(ig,k+1)-zlev(ig,k)))
    5667       ! s         *(zlev(ig,k+1)-zlev(ig,k))
    5668       norme(ig) = norme(ig) + max(0., (ztv(ig,k)-ztv(ig,k+1))/(zlev(ig, &
    5669         k+1)-zlev(ig,k)))
    5670       ! s          *(zlev(ig,k+1)-zlev(ig,k))
    5671     END DO
    5672   END DO
    5673   DO ig = 1, ngrid
    5674     IF (norme(ig)>1.E-10) THEN
    5675       zalim(ig) = max(10.*zalim(ig)/norme(ig), zlev(ig,2))
    5676       ! zalim(ig)=min(zalim(ig),zlev(ig,lentr(ig)))
     5271
     5272    IF (1==0) THEN
     5273      CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
     5274              zu, zv, pduadj, pdvadj, zua, zva)
     5275    ELSE
     5276      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
     5277              zua)
     5278      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
     5279              zva)
    56775280    END IF
    5678   END DO
    5679   ! détermination du lalim correspondant
    5680   DO k = 1, klev - 1
    5681     DO ig = 1, ngrid
    5682       IF ((zalim(ig)>zlev(ig,k)) .AND. (zalim(ig)<=zlev(ig,k+1))) THEN
    5683         lalim(ig) = k
    5684       END IF
    5685     END DO
    5686   END DO
    5687 
    5688   ! definition de l'entrainement des couches
    5689   DO l = 1, klev - 1
    5690     DO ig = 1, ngrid
    5691       IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<lentr(ig)) THEN
    5692         entr_star(ig, l) = max((ztv(ig,l)-ztv(ig,l+1)), 0.) & ! s
    5693                                                               ! *(zlev(ig,l+1)-zlev(ig,l))
    5694           *sqrt(zlev(ig,l+1))
    5695         ! autre def
    5696         ! entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
    5697         ! s                         /zlev(ig,lentr(ig)+2)))**(3./2.)
    5698       END IF
    5699     END DO
    5700   END DO
    5701   ! nouveau test
    5702   ! if (therm) THEN
    5703   DO l = 1, klev - 1
    5704     DO ig = 1, ngrid
    5705       IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lalim(ig) .AND. &
    5706           zalim(ig)>1.E-10) THEN
    5707         ! if (l.le.lentr(ig)) THEN
    5708         ! entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
    5709         ! s                         /zalim(ig)))**(3./2.)
    5710         ! WRITE(10,*)zlev(ig,l),entr_star(ig,l)
    5711       END IF
    5712     END DO
    5713   END DO
    5714   ! END IF
    5715   ! pas de thermique si couche 1 stable
    5716   DO ig = 1, ngrid
    5717     IF (lmin(ig)>5) THEN
    5718       DO l = 1, klev
    5719         entr_star(ig, l) = 0.
    5720       END DO
    5721     END IF
    5722   END DO
    5723   ! calcul de l entrainement total
    5724   DO ig = 1, ngrid
    5725     entr_star_tot(ig) = 0.
    5726   END DO
    5727   DO ig = 1, ngrid
    5728     DO k = 1, klev
    5729       entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k)
    5730     END DO
    5731   END DO
    5732   ! Calcul entrainement normalise
    5733   DO ig = 1, ngrid
    5734     IF (entr_star_tot(ig)>1.E-10) THEN
    5735       ! do l=1,lentr(ig)
    5736       DO l = 1, klev
    5737         ! def possibles pour entr_star: zdthetadz, dthetadz, zdtheta
    5738         entr_star(ig, l) = entr_star(ig, l)/entr_star_tot(ig)
    5739       END DO
    5740     END IF
    5741   END DO
    5742 
    5743   ! PRINT*,'fin calcul entr_star'
    5744   DO k = 1, klev
    5745     DO ig = 1, ngrid
    5746       ztva(ig, k) = ztv(ig, k)
    5747     END DO
    5748   END DO
    5749   ! RC
    5750   ! PRINT*,'7 OK convect8'
    5751   DO k = 1, klev + 1
    5752     DO ig = 1, ngrid
    5753       zw2(ig, k) = 0.
    5754       fmc(ig, k) = 0.
    5755       ! CR
    5756       f_star(ig, k) = 0.
    5757       ! RC
    5758       larg_cons(ig, k) = 0.
    5759       larg_detr(ig, k) = 0.
    5760       wa_moy(ig, k) = 0.
    5761     END DO
    5762   END DO
    5763 
    5764   ! PRINT*,'8 OK convect8'
    5765   DO ig = 1, ngrid
    5766     linter(ig) = 1.
    5767     lmaxa(ig) = 1
    5768     lmix(ig) = 1
    5769     wmaxa(ig) = 0.
    5770   END DO
    5771 
    5772   ! CR:
    5773   DO l = 1, nlay - 2
    5774     DO ig = 1, ngrid
    5775       IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. &
    5776           zw2(ig,l)<1E-10) THEN
    5777         f_star(ig, l+1) = entr_star(ig, l)
    5778         ! test:calcul de dteta
    5779         zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* &
    5780           (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l))
    5781         larg_detr(ig, l) = 0.
    5782       ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, &
    5783           l)>1.E-10)) THEN
    5784         f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l)
    5785         ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)*ztv(ig,l))/ &
    5786           f_star(ig, l+1)
    5787         zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + &
    5788           2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l))
    5789       END IF
    5790       ! determination de zmax continu par interpolation lineaire
    5791       IF (zw2(ig,l+1)<0.) THEN
    5792         ! test
    5793         IF (abs(zw2(ig,l+1)-zw2(ig,l))<1E-10) THEN
    5794           ! PRINT*,'pb linter'
    5795         END IF
    5796         linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( &
    5797           ig,l))
    5798         zw2(ig, l+1) = 0.
    5799         lmaxa(ig) = l
    5800       ELSE
    5801         IF (zw2(ig,l+1)<0.) THEN
    5802           ! PRINT*,'pb1 zw2<0'
    5803         END IF
    5804         wa_moy(ig, l+1) = sqrt(zw2(ig,l+1))
    5805       END IF
    5806       IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN
    5807         ! lmix est le niveau de la couche ou w (wa_moy) est maximum
    5808         lmix(ig) = l + 1
    5809         wmaxa(ig) = wa_moy(ig, l+1)
    5810       END IF
    5811     END DO
    5812   END DO
    5813   ! PRINT*,'fin calcul zw2'
    5814 
    5815   ! Calcul de la couche correspondant a la hauteur du thermique
    5816   DO ig = 1, ngrid
    5817     lmax(ig) = lentr(ig)
    5818     ! lmax(ig)=lalim(ig)
    5819   END DO
    5820   DO ig = 1, ngrid
    5821     DO l = nlay, lentr(ig) + 1, -1
    5822       ! do l=nlay,lalim(ig)+1,-1
    5823       IF (zw2(ig,l)<=1.E-10) THEN
    5824         lmax(ig) = l - 1
    5825       END IF
    5826     END DO
    5827   END DO
    5828   ! pas de thermique si couche 1 stable
    5829   DO ig = 1, ngrid
    5830     IF (lmin(ig)>5) THEN
    5831       lmax(ig) = 1
    5832       lmin(ig) = 1
    5833       lentr(ig) = 1
    5834       lalim(ig) = 1
    5835     END IF
    5836   END DO
    5837 
    5838   ! Determination de zw2 max
    5839   DO ig = 1, ngrid
    5840     wmax(ig) = 0.
    5841   END DO
    5842 
    5843   DO l = 1, nlay
    5844     DO ig = 1, ngrid
    5845       IF (l<=lmax(ig)) THEN
    5846         IF (zw2(ig,l)<0.) THEN
    5847           ! PRINT*,'pb2 zw2<0'
    5848         END IF
    5849         zw2(ig, l) = sqrt(zw2(ig,l))
    5850         wmax(ig) = max(wmax(ig), zw2(ig,l))
    5851       ELSE
    5852         zw2(ig, l) = 0.
    5853       END IF
    5854     END DO
    5855   END DO
    5856 
    5857   ! Longueur caracteristique correspondant a la hauteur des thermiques.
    5858   DO ig = 1, ngrid
    5859     zmax(ig) = 0.
    5860     zlevinter(ig) = zlev(ig, 1)
    5861   END DO
    5862   DO ig = 1, ngrid
    5863     ! calcul de zlevinter
    5864     zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + &
    5865       zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
    5866     zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig)))
    5867   END DO
    5868   DO ig = 1, ngrid
    5869     ! WRITE(8,*)zmax(ig),lmax(ig),lentr(ig),lmin(ig)
    5870   END DO
    5871   ! on stope après les calculs de zmax et wmax
    5872   RETURN
    5873 
    5874   ! PRINT*,'avant fermeture'
    5875   ! Fermeture,determination de f
    5876   ! Attention! entrainement normalisé ou pas?
    5877   DO ig = 1, ngrid
    5878     entr_star2(ig) = 0.
    5879   END DO
    5880   DO ig = 1, ngrid
    5881     IF (entr_star_tot(ig)<1.E-10) THEN
    5882       f(ig) = 0.
    5883     ELSE
    5884       DO k = lmin(ig), lentr(ig)
    5885         ! do k=lmin(ig),lalim(ig)
    5886         entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( &
    5887           zlev(ig,k+1)-zlev(ig,k)))
    5888       END DO
    5889       ! Nouvelle fermeture
    5890       f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*entr_star2(ig))
    5891       ! s            *entr_star_tot(ig)
    5892       ! test
    5893       ! if (first) THEN
    5894       f(ig) = f(ig) + (f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)*wmax(ig))
    5895       ! END IF
    5896     END IF
    5897     f0(ig) = f(ig)
    5898     ! first=.TRUE.
    5899   END DO
    5900   ! PRINT*,'apres fermeture'
    5901   ! on stoppe après la fermeture
    5902   RETURN
    5903   ! Calcul de l'entrainement
    5904   DO k = 1, klev
    5905     DO ig = 1, ngrid
    5906       entr(ig, k) = f(ig)*entr_star(ig, k)
    5907     END DO
    5908   END DO
    5909   ! on stoppe après le calcul de entr
    5910   ! RETURN
    5911   ! CR:test pour entrainer moins que la masse
    5912   ! do ig=1,ngrid
    5913   ! do l=1,lentr(ig)
    5914   ! if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) THEN
    5915   ! entr(ig,l+1)=entr(ig,l+1)+entr(ig,l)
    5916   ! s                       -0.9*masse(ig,l)/ptimestep
    5917   ! entr(ig,l)=0.9*masse(ig,l)/ptimestep
    5918   ! END IF
    5919   ! enddo
    5920   ! enddo
    5921   ! CR: fin test
    5922   ! Calcul des flux
    5923   DO ig = 1, ngrid
    5924     DO l = 1, lmax(ig) - 1
    5925       fmc(ig, l+1) = fmc(ig, l) + entr(ig, l)
    5926     END DO
    5927   END DO
    5928 
    5929   ! RC
    5930 
    5931 
    5932   ! PRINT*,'9 OK convect8'
    5933   ! PRINT*,'WA1 ',wa_moy
    5934 
    5935   ! determination de l'indice du debut de la mixed layer ou w decroit
    5936 
    5937   ! calcul de la largeur de chaque ascendance dans le cas conservatif.
    5938   ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
    5939   ! d'une couche est égale à la hauteur de la couche alimentante.
    5940   ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
    5941   ! de la vitesse d'entrainement horizontal dans la couche alimentante.
    5942 
    5943   DO l = 2, nlay
    5944     DO ig = 1, ngrid
    5945       IF (l<=lmaxa(ig)) THEN
    5946         zw = max(wa_moy(ig,l), 1.E-10)
    5947         larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw)
    5948       END IF
    5949     END DO
    5950   END DO
    5951 
    5952   DO l = 2, nlay
    5953     DO ig = 1, ngrid
    5954       IF (l<=lmaxa(ig)) THEN
    5955         ! if (idetr.EQ.0) THEN
    5956         ! cette option est finalement en dur.
    5957         IF ((l_mix*zlev(ig,l))<0.) THEN
    5958           ! PRINT*,'pb l_mix*zlev<0'
    5959         END IF
    5960         ! CR: test: nouvelle def de lambda
    5961         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    5962         IF (zw2(ig,l)>1.E-10) THEN
    5963           larg_detr(ig, l) = sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
    5964         ELSE
    5965           larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l))
    5966         END IF
    5967         ! RC
    5968         ! ELSE IF (idetr.EQ.1) THEN
    5969         ! larg_detr(ig,l)=larg_cons(ig,l)
    5970         ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
    5971         ! ELSE IF (idetr.EQ.2) THEN
    5972         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    5973         ! s            *sqrt(wa_moy(ig,l))
    5974         ! ELSE IF (idetr.EQ.4) THEN
    5975         ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
    5976         ! s            *wa_moy(ig,l)
    5977         ! END IF
    5978       END IF
    5979     END DO
    5980   END DO
    5981 
    5982   ! PRINT*,'10 OK convect8'
    5983   ! PRINT*,'WA2 ',wa_moy
    5984   ! calcul de la fraction de la maille concernée par l'ascendance en tenant
    5985   ! compte de l'epluchage du thermique.
    5986 
    5987   ! CR def de  zmix continu (profil parabolique des vitesses)
    5988   DO ig = 1, ngrid
    5989     IF (lmix(ig)>1.) THEN
    5990       ! test
    5991       IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- &
    5992           (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- &
    5993           zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- &
    5994           (zlev(ig,lmix(ig)))))>1E-10) THEN
    5995 
    5996         zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) &
    5997           )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, &
    5998           lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ &
    5999           (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- &
    6000           (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- &
    6001           zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
    6002       ELSE
    6003         zmix(ig) = zlev(ig, lmix(ig))
    6004         ! PRINT*,'pb zmix'
    6005       END IF
    6006     ELSE
    6007       zmix(ig) = 0.
    6008     END IF
    6009     ! test
    6010     IF ((zmax(ig)-zmix(ig))<0.) THEN
    6011       zmix(ig) = 0.99*zmax(ig)
    6012       ! PRINT*,'pb zmix>zmax'
    6013     END IF
    6014   END DO
    6015 
    6016   ! calcul du nouveau lmix correspondant
    6017   DO ig = 1, ngrid
    6018     DO l = 1, klev
    6019       IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)<zlev(ig,l+1)) THEN
    6020         lmix(ig) = l
    6021       END IF
    6022     END DO
    6023   END DO
    6024 
    6025   DO l = 2, nlay
    6026     DO ig = 1, ngrid
    6027       IF (larg_cons(ig,l)>1.) THEN
    6028         ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
    6029         fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig))
    6030         ! test
    6031         fraca(ig, l) = max(fraca(ig,l), 0.)
    6032         fraca(ig, l) = min(fraca(ig,l), 0.5)
    6033         fracd(ig, l) = 1. - fraca(ig, l)
    6034         fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig))
    6035       ELSE
    6036         ! wa_moy(ig,l)=0.
    6037         fraca(ig, l) = 0.
    6038         fracc(ig, l) = 0.
    6039         fracd(ig, l) = 1.
    6040       END IF
    6041     END DO
    6042   END DO
    6043   ! CR: calcul de fracazmix
    6044   DO ig = 1, ngrid
    6045     fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ &
    6046       (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + &
    6047       fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig &
    6048       ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
    6049   END DO
    6050 
    6051   DO l = 2, nlay
    6052     DO ig = 1, ngrid
    6053       IF (larg_cons(ig,l)>1.) THEN
    6054         IF (l>lmix(ig)) THEN
    6055           ! test
    6056           IF (zmax(ig)-zmix(ig)<1.E-10) THEN
    6057             ! PRINT*,'pb xxx'
    6058             xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
    6059           ELSE
    6060             xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
    6061           END IF
    6062           IF (idetr==0) THEN
    6063             fraca(ig, l) = fracazmix(ig)
    6064           ELSE IF (idetr==1) THEN
    6065             fraca(ig, l) = fracazmix(ig)*xxx(ig, l)
    6066           ELSE IF (idetr==2) THEN
    6067             fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
    6068           ELSE
    6069             fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2
    6070           END IF
    6071           ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
    6072           fraca(ig, l) = max(fraca(ig,l), 0.)
    6073           fraca(ig, l) = min(fraca(ig,l), 0.5)
    6074           fracd(ig, l) = 1. - fraca(ig, l)
    6075           fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig))
    6076         END IF
    6077       END IF
    6078     END DO
    6079   END DO
    6080 
    6081   ! PRINT*,'fin calcul fraca'
    6082   ! PRINT*,'11 OK convect8'
    6083   ! PRINT*,'Ea3 ',wa_moy
    6084   ! ------------------------------------------------------------------
    6085   ! Calcul de fracd, wd
    6086   ! somme wa - wd = 0
    6087   ! ------------------------------------------------------------------
    6088 
    6089 
    6090   DO ig = 1, ngrid
    6091     fm(ig, 1) = 0.
    6092     fm(ig, nlay+1) = 0.
    6093   END DO
    6094 
    6095   DO l = 2, nlay
    6096     DO ig = 1, ngrid
    6097       fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l)
    6098       ! CR:test
    6099       IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN
    6100         fm(ig, l) = fm(ig, l-1)
    6101         ! WRITE(1,*)'ajustement fm, l',l
    6102       END IF
    6103       ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
    6104       ! RC
    6105     END DO
    6106     DO ig = 1, ngrid
    6107       IF (fracd(ig,l)<0.1) THEN
    6108         abort_message = 'fracd trop petit'
    6109         CALL abort_physic(modname, abort_message, 1)
    6110 
    6111       ELSE
    6112         ! vitesse descendante "diagnostique"
    6113         wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l))
    6114       END IF
    6115     END DO
    6116   END DO
    6117 
    6118   DO l = 1, nlay
    6119     DO ig = 1, ngrid
    6120       ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
    6121       masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg
    6122     END DO
    6123   END DO
    6124 
    6125   ! PRINT*,'12 OK convect8'
    6126   ! PRINT*,'WA4 ',wa_moy
    6127   ! c------------------------------------------------------------------
    6128   ! calcul du transport vertical
    6129   ! ------------------------------------------------------------------
    6130 
    6131   GO TO 4444
    6132   ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
    6133   DO l = 2, nlay - 1
    6134     DO ig = 1, ngrid
    6135       IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( &
    6136           ig,l+1)) THEN
    6137         ! PRINT*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
    6138         ! s         ,fm(ig,l+1)*ptimestep
    6139         ! s         ,'   M=',masse(ig,l),masse(ig,l+1)
    6140       END IF
    6141     END DO
    6142   END DO
    6143 
    6144   DO l = 1, nlay
    6145     DO ig = 1, ngrid
    6146       IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN
    6147         ! PRINT*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
    6148         ! s         ,entr(ig,l)*ptimestep
    6149         ! s         ,'   M=',masse(ig,l)
    6150       END IF
    6151     END DO
    6152   END DO
    6153 
    6154   DO l = 1, nlay
    6155     DO ig = 1, ngrid
    6156       IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN
    6157         ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
    6158         ! s         ,'   FM=',fm(ig,l)
    6159       END IF
    6160       IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN
    6161         ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
    6162         ! s         ,'   M=',masse(ig,l)
    6163         ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
    6164         ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
    6165         ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
    6166         ! s                ,zlev(ig,l+1),zlev(ig,l)
    6167         ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
    6168         ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
    6169       END IF
    6170       IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN
    6171         ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
    6172         ! s         ,'   E=',entr(ig,l)
    6173       END IF
    6174     END DO
    6175   END DO
    6176 
    6177 4444 CONTINUE
    6178 
    6179   ! CR:redefinition du entr
    6180   DO l = 1, nlay
    6181     DO ig = 1, ngrid
    6182       detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1)
    6183       IF (detr(ig,l)<0.) THEN
    6184         ! entr(ig,l)=entr(ig,l)-detr(ig,l)
    6185         fm(ig, l+1) = fm(ig, l) + entr(ig, l)
    6186         detr(ig, l) = 0.
    6187         ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
    6188       END IF
    6189     END DO
    6190   END DO
    6191   ! RC
    6192   IF (w2di==1) THEN
    6193     fm0 = fm0 + ptimestep*(fm-fm0)/tho
    6194     entr0 = entr0 + ptimestep*(entr-entr0)/tho
    6195   ELSE
    6196     fm0 = fm
    6197     entr0 = entr
    6198   END IF
    6199 
    6200   IF (1==1) THEN
    6201     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, &
    6202       zha)
    6203     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, &
    6204       zoa)
    6205   ELSE
    6206     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
    6207       zdhadj, zha)
    6208     CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
    6209       pdoadj, zoa)
    6210   END IF
    6211 
    6212   IF (1==0) THEN
    6213     CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
    6214       zu, zv, pduadj, pdvadj, zua, zva)
    6215   ELSE
    6216     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
    6217       zua)
    6218     CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
    6219       zva)
    6220   END IF
    6221 
    6222   DO l = 1, nlay
    6223     DO ig = 1, ngrid
    6224       zf = 0.5*(fracc(ig,l)+fracc(ig,l+1))
    6225       zf2 = zf/(1.-zf)
    6226       thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2
    6227       wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
    6228     END DO
    6229   END DO
    6230 
    6231 
    6232 
    6233   ! PRINT*,'13 OK convect8'
    6234   ! PRINT*,'WA5 ',wa_moy
    6235   DO l = 1, nlay
    6236     DO ig = 1, ngrid
    6237       pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l)
    6238     END DO
    6239   END DO
    6240 
    6241 
    6242   ! do l=1,nlay
    6243   ! do ig=1,ngrid
    6244   ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
    6245   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    6246   ! s         ,'   pdtadj=',pdtadj(ig,l)
    6247   ! END IF
    6248   ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
    6249   ! PRINT*,'WARN!!! ig=',ig,'  l=',l
    6250   ! s         ,'   pdoadj=',pdoadj(ig,l)
    6251   ! END IF
    6252   ! enddo
    6253   ! enddo
    6254 
    6255   ! PRINT*,'14 OK convect8'
    6256   ! ------------------------------------------------------------------
    6257   ! Calculs pour les sorties
    6258   ! ------------------------------------------------------------------
    6259 
    6260   IF (sorties) THEN
     5281
    62615282    DO l = 1, nlay
    62625283      DO ig = 1, ngrid
    6263         zla(ig, l) = (1.-fracd(ig,l))*zmax(ig)
    6264         zld(ig, l) = fracd(ig, l)*zmax(ig)
    6265         IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ &
    6266           (1.-fracd(ig,l))
    6267       END DO
    6268     END DO
    6269 
    6270     ! deja fait
     5284        zf = 0.5 * (fracc(ig, l) + fracc(ig, l + 1))
     5285        zf2 = zf / (1. - zf)
     5286        thetath2(ig, l) = zf2 * (zha(ig, l) - zh(ig, l))**2
     5287        wth2(ig, l) = zf2 * (0.5 * (wa_moy(ig, l) + wa_moy(ig, l + 1)))**2
     5288      END DO
     5289    END DO
     5290
     5291
     5292
     5293    ! PRINT*,'13 OK convect8'
     5294    ! PRINT*,'WA5 ',wa_moy
     5295    DO l = 1, nlay
     5296      DO ig = 1, ngrid
     5297        pdtadj(ig, l) = zdhadj(ig, l) * zpspsk(ig, l)
     5298      END DO
     5299    END DO
     5300
     5301
    62715302    ! do l=1,nlay
    62725303    ! do ig=1,ngrid
    6273     ! detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
    6274     ! if (detr(ig,l).lt.0.) THEN
    6275     ! entr(ig,l)=entr(ig,l)-detr(ig,l)
    6276     ! detr(ig,l)=0.
    6277     ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
     5304    ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
     5305    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     5306    ! s         ,'   pdtadj=',pdtadj(ig,l)
     5307    ! END IF
     5308    ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
     5309    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     5310    ! s         ,'   pdoadj=',pdoadj(ig,l)
    62785311    ! END IF
    62795312    ! enddo
    62805313    ! enddo
    62815314
    6282     ! PRINT*,'15 OK convect8'
    6283 
    6284     isplit = isplit + 1
    6285 
    6286 
    6287     ! #define und
    6288     GO TO 123
     5315    ! PRINT*,'14 OK convect8'
     5316    ! ------------------------------------------------------------------
     5317    ! Calculs pour les sorties
     5318    ! ------------------------------------------------------------------
     5319
     5320  END SUBROUTINE thermcell_sec
     5321
     5322  SUBROUTINE calcul_sec(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, pu, &
     5323          pv, pt, po, zmax, wmax, zw2, lmix & ! s
     5324          ! ,pu_therm,pv_therm
     5325          , r_aspect, l_mix, w2di, tho)
     5326
     5327    USE dimphy
     5328    IMPLICIT NONE
     5329
     5330    ! =======================================================================
     5331
     5332    ! Calcul du transport verticale dans la couche limite en presence
     5333    ! de "thermiques" explicitement representes
     5334
     5335    ! Réécriture à partir d'un listing papier à Habas, le 14/02/00
     5336
     5337    ! le thermique est supposé homogène et dissipé par mélange avec
     5338    ! son environnement. la longueur l_mix contrôle l'efficacité du
     5339    ! mélange
     5340
     5341    ! Le calcul du transport des différentes espèces se fait en prenant
     5342    ! en compte:
     5343    ! 1. un flux de masse montant
     5344    ! 2. un flux de masse descendant
     5345    ! 3. un entrainement
     5346    ! 4. un detrainement
     5347
     5348    ! =======================================================================
     5349
     5350    ! -----------------------------------------------------------------------
     5351    ! declarations:
     5352    ! -------------
     5353
     5354    include "YOMCST.h"
     5355
     5356    ! arguments:
     5357    ! ----------
     5358
     5359    INTEGER ngrid, nlay, w2di
     5360    REAL tho
     5361    REAL ptimestep, l_mix, r_aspect
     5362    REAL pt(ngrid, nlay), pdtadj(ngrid, nlay)
     5363    REAL pu(ngrid, nlay), pduadj(ngrid, nlay)
     5364    REAL pv(ngrid, nlay), pdvadj(ngrid, nlay)
     5365    REAL po(ngrid, nlay), pdoadj(ngrid, nlay)
     5366    REAL pplay(ngrid, nlay), pplev(ngrid, nlay + 1)
     5367    REAL pphi(ngrid, nlay)
     5368
     5369    INTEGER idetr
     5370    SAVE idetr
     5371    DATA idetr/3/
     5372    !$OMP THREADPRIVATE(idetr)
     5373    ! local:
     5374    ! ------
     5375
     5376    INTEGER ig, k, l, lmaxa(klon), lmix(klon)
     5377    REAL zsortie1d(klon)
     5378    ! CR: on remplace lmax(klon,klev+1)
     5379    INTEGER lmax(klon), lmin(klon), lentr(klon)
     5380    REAL linter(klon)
     5381    REAL zmix(klon), fracazmix(klon)
     5382    ! RC
     5383    REAL zmax(klon), zw, zw2(klon, klev + 1), ztva(klon, klev)
     5384
     5385    REAL zlev(klon, klev + 1), zlay(klon, klev)
     5386    REAL zh(klon, klev), zdhadj(klon, klev)
     5387    REAL ztv(klon, klev)
     5388    REAL zu(klon, klev), zv(klon, klev), zo(klon, klev)
     5389    REAL wh(klon, klev + 1)
     5390    REAL wu(klon, klev + 1), wv(klon, klev + 1), wo(klon, klev + 1)
     5391    REAL zla(klon, klev + 1)
     5392    REAL zwa(klon, klev + 1)
     5393    REAL zld(klon, klev + 1)
     5394    ! real zwd(klon,klev+1)
     5395    REAL zsortie(klon, klev)
     5396    REAL zva(klon, klev)
     5397    REAL zua(klon, klev)
     5398    REAL zoa(klon, klev)
     5399
     5400    REAL zha(klon, klev)
     5401    REAL wa_moy(klon, klev + 1)
     5402    REAL fraca(klon, klev + 1)
     5403    REAL fracc(klon, klev + 1)
     5404    REAL zf, zf2
     5405    REAL thetath2(klon, klev), wth2(klon, klev)
     5406    ! common/comtherm/thetath2,wth2
     5407
     5408    REAL count_time
     5409    ! integer isplit,nsplit
     5410    INTEGER isplit, nsplit, ialt
     5411    PARAMETER (nsplit = 10)
     5412    DATA isplit/0/
     5413    SAVE isplit
     5414    !$OMP THREADPRIVATE(isplit)
     5415
     5416    LOGICAL sorties
     5417    REAL rho(klon, klev), rhobarz(klon, klev + 1), masse(klon, klev)
     5418    REAL zpspsk(klon, klev)
     5419
     5420    ! real wmax(klon,klev),wmaxa(klon)
     5421    REAL wmax(klon), wmaxa(klon)
     5422    REAL wa(klon, klev, klev + 1)
     5423    REAL wd(klon, klev + 1)
     5424    REAL larg_part(klon, klev, klev + 1)
     5425    REAL fracd(klon, klev + 1)
     5426    REAL xxx(klon, klev + 1)
     5427    REAL larg_cons(klon, klev + 1)
     5428    REAL larg_detr(klon, klev + 1)
     5429    REAL fm0(klon, klev + 1), entr0(klon, klev), detr(klon, klev)
     5430    REAL pu_therm(klon, klev), pv_therm(klon, klev)
     5431    REAL fm(klon, klev + 1), entr(klon, klev)
     5432    REAL fmc(klon, klev + 1)
     5433
     5434    ! CR:nouvelles variables
     5435    REAL f_star(klon, klev + 1), entr_star(klon, klev)
     5436    REAL entr_star_tot(klon), entr_star2(klon)
     5437    REAL zalim(klon)
     5438    INTEGER lalim(klon)
     5439    REAL norme(klon)
     5440    REAL f(klon), f0(klon)
     5441    REAL zlevinter(klon)
     5442    LOGICAL therm
     5443    LOGICAL first
     5444    DATA first/.FALSE./
     5445    SAVE first
     5446    !$OMP THREADPRIVATE(first)
     5447    ! RC
     5448
     5449    CHARACTER *2 str2
     5450    CHARACTER *10 str10
     5451
     5452    CHARACTER (LEN = 20) :: modname = 'calcul_sec'
     5453    CHARACTER (LEN = 80) :: abort_message
     5454
     5455
     5456    ! LOGICAL vtest(klon),down
     5457
     5458    INTEGER ncorrec
     5459    SAVE ncorrec
     5460    DATA ncorrec/0/
     5461    !$OMP THREADPRIVATE(ncorrec)
     5462
     5463
     5464    ! -----------------------------------------------------------------------
     5465    ! initialisation:
     5466    ! ---------------
     5467
     5468    sorties = .TRUE.
     5469    IF (ngrid/=klon) THEN
     5470      PRINT *
     5471      PRINT *, 'STOP dans convadj'
     5472      PRINT *, 'ngrid    =', ngrid
     5473      PRINT *, 'klon  =', klon
     5474    END IF
     5475
     5476    ! -----------------------------------------------------------------------
     5477    ! incrementation eventuelle de tendances precedentes:
     5478    ! ---------------------------------------------------
     5479
     5480    ! PRINT*,'0 OK convect8'
     5481
     5482    DO l = 1, nlay
     5483      DO ig = 1, ngrid
     5484        zpspsk(ig, l) = (pplay(ig, l) / pplev(ig, 1))**rkappa
     5485        zh(ig, l) = pt(ig, l) / zpspsk(ig, l)
     5486        zu(ig, l) = pu(ig, l)
     5487        zv(ig, l) = pv(ig, l)
     5488        zo(ig, l) = po(ig, l)
     5489        ztv(ig, l) = zh(ig, l) * (1. + 0.61 * zo(ig, l))
     5490      END DO
     5491    END DO
     5492
     5493    ! PRINT*,'1 OK convect8'
     5494    ! --------------------
     5495
     5496
     5497    ! + + + + + + + + + + +
     5498
     5499
     5500    ! wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
     5501    ! wh,wt,wo ...
     5502
     5503    ! + + + + + + + + + + +  zh,zu,zv,zo,rho
     5504
     5505
     5506    ! --------------------   zlev(1)
     5507    ! \\\\\\\\\\\\\\\\\\\\
     5508
     5509
     5510
     5511    ! -----------------------------------------------------------------------
     5512    ! Calcul des altitudes des couches
     5513    ! -----------------------------------------------------------------------
     5514
     5515    DO l = 2, nlay
     5516      DO ig = 1, ngrid
     5517        zlev(ig, l) = 0.5 * (pphi(ig, l) + pphi(ig, l - 1)) / rg
     5518      END DO
     5519    END DO
     5520    DO ig = 1, ngrid
     5521      zlev(ig, 1) = 0.
     5522      zlev(ig, nlay + 1) = (2. * pphi(ig, klev) - pphi(ig, klev - 1)) / rg
     5523    END DO
     5524    DO l = 1, nlay
     5525      DO ig = 1, ngrid
     5526        zlay(ig, l) = pphi(ig, l) / rg
     5527      END DO
     5528    END DO
     5529
     5530    ! PRINT*,'2 OK convect8'
     5531    ! -----------------------------------------------------------------------
     5532    ! Calcul des densites
     5533    ! -----------------------------------------------------------------------
     5534
     5535    DO l = 1, nlay
     5536      DO ig = 1, ngrid
     5537        rho(ig, l) = pplay(ig, l) / (zpspsk(ig, l) * rd * zh(ig, l))
     5538      END DO
     5539    END DO
     5540
     5541    DO l = 2, nlay
     5542      DO ig = 1, ngrid
     5543        rhobarz(ig, l) = 0.5 * (rho(ig, l) + rho(ig, l - 1))
     5544      END DO
     5545    END DO
     5546
     5547    DO k = 1, nlay
     5548      DO l = 1, nlay + 1
     5549        DO ig = 1, ngrid
     5550          wa(ig, k, l) = 0.
     5551        END DO
     5552      END DO
     5553    END DO
     5554
     5555    ! PRINT*,'3 OK convect8'
     5556    ! ------------------------------------------------------------------
     5557    ! Calcul de w2, quarre de w a partir de la cape
     5558    ! a partir de w2, on calcule wa, vitesse de l'ascendance
     5559
     5560    ! ATTENTION: Dans cette version, pour cause d'economie de memoire,
     5561    ! w2 est stoke dans wa
     5562
     5563    ! ATTENTION: dans convect8, on n'utilise le calcule des wa
     5564    ! independants par couches que pour calculer l'entrainement
     5565    ! a la base et la hauteur max de l'ascendance.
     5566
     5567    ! Indicages:
     5568    ! l'ascendance provenant du niveau k traverse l'interface l avec
     5569    ! une vitesse wa(k,l).
     5570
     5571    ! --------------------
     5572
     5573    ! + + + + + + + + + +
     5574
     5575    ! wa(k,l)   ----       --------------------    l
     5576    ! /\
     5577    ! /||\       + + + + + + + + + +
     5578    ! ||
     5579    ! ||        --------------------
     5580    ! ||
     5581    ! ||        + + + + + + + + + +
     5582    ! ||
     5583    ! ||        --------------------
     5584    ! ||__
     5585    ! |___      + + + + + + + + + +     k
     5586
     5587    ! --------------------
     5588
     5589
     5590
     5591    ! ------------------------------------------------------------------
     5592
     5593    ! CR: ponderation entrainement des couches instables
     5594    ! def des entr_star tels que entr=f*entr_star
     5595    DO l = 1, klev
     5596      DO ig = 1, ngrid
     5597        entr_star(ig, l) = 0.
     5598      END DO
     5599    END DO
     5600    ! determination de la longueur de la couche d entrainement
     5601    DO ig = 1, ngrid
     5602      lentr(ig) = 1
     5603    END DO
     5604
     5605    ! on ne considere que les premieres couches instables
     5606    therm = .FALSE.
     5607    DO k = nlay - 2, 1, -1
     5608      DO ig = 1, ngrid
     5609        IF (ztv(ig, k)>ztv(ig, k + 1) .AND. ztv(ig, k + 1)<=ztv(ig, k + 2)) THEN
     5610          lentr(ig) = k + 1
     5611          therm = .TRUE.
     5612        END IF
     5613      END DO
     5614    END DO
     5615    ! limitation de la valeur du lentr
     5616    ! do ig=1,ngrid
     5617    ! lentr(ig)=min(5,lentr(ig))
     5618    ! enddo
     5619    ! determination du lmin: couche d ou provient le thermique
     5620    DO ig = 1, ngrid
     5621      lmin(ig) = 1
     5622    END DO
     5623    DO ig = 1, ngrid
     5624      DO l = nlay, 2, -1
     5625        IF (ztv(ig, l - 1)>ztv(ig, l)) THEN
     5626          lmin(ig) = l - 1
     5627        END IF
     5628      END DO
     5629    END DO
     5630    ! initialisations
     5631    DO ig = 1, ngrid
     5632      zalim(ig) = 0.
     5633      norme(ig) = 0.
     5634      lalim(ig) = 1
     5635    END DO
     5636    DO k = 1, klev - 1
     5637      DO ig = 1, ngrid
     5638        zalim(ig) = zalim(ig) + zlev(ig, k) * max(0., (ztv(ig, k) - ztv(ig, &
     5639                k + 1)) / (zlev(ig, k + 1) - zlev(ig, k)))
     5640        ! s         *(zlev(ig,k+1)-zlev(ig,k))
     5641        norme(ig) = norme(ig) + max(0., (ztv(ig, k) - ztv(ig, k + 1)) / (zlev(ig, &
     5642                k + 1) - zlev(ig, k)))
     5643        ! s          *(zlev(ig,k+1)-zlev(ig,k))
     5644      END DO
     5645    END DO
     5646    DO ig = 1, ngrid
     5647      IF (norme(ig)>1.E-10) THEN
     5648        zalim(ig) = max(10. * zalim(ig) / norme(ig), zlev(ig, 2))
     5649        ! zalim(ig)=min(zalim(ig),zlev(ig,lentr(ig)))
     5650      END IF
     5651    END DO
     5652    ! détermination du lalim correspondant
     5653    DO k = 1, klev - 1
     5654      DO ig = 1, ngrid
     5655        IF ((zalim(ig)>zlev(ig, k)) .AND. (zalim(ig)<=zlev(ig, k + 1))) THEN
     5656          lalim(ig) = k
     5657        END IF
     5658      END DO
     5659    END DO
     5660
     5661    ! definition de l'entrainement des couches
     5662    DO l = 1, klev - 1
     5663      DO ig = 1, ngrid
     5664        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. l>=lmin(ig) .AND. l<lentr(ig)) THEN
     5665          entr_star(ig, l) = max((ztv(ig, l) - ztv(ig, l + 1)), 0.) & ! s
     5666                  ! *(zlev(ig,l+1)-zlev(ig,l))
     5667                  * sqrt(zlev(ig, l + 1))
     5668          ! autre def
     5669          ! entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
     5670          ! s                         /zlev(ig,lentr(ig)+2)))**(3./2.)
     5671        END IF
     5672      END DO
     5673    END DO
     5674    ! nouveau test
     5675    ! if (therm) THEN
     5676    DO l = 1, klev - 1
     5677      DO ig = 1, ngrid
     5678        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. l>=lmin(ig) .AND. l<=lalim(ig) .AND. &
     5679                zalim(ig)>1.E-10) THEN
     5680          ! if (l.le.lentr(ig)) THEN
     5681          ! entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
     5682          ! s                         /zalim(ig)))**(3./2.)
     5683          ! WRITE(10,*)zlev(ig,l),entr_star(ig,l)
     5684        END IF
     5685      END DO
     5686    END DO
     5687    ! END IF
     5688    ! pas de thermique si couche 1 stable
     5689    DO ig = 1, ngrid
     5690      IF (lmin(ig)>5) THEN
     5691        DO l = 1, klev
     5692          entr_star(ig, l) = 0.
     5693        END DO
     5694      END IF
     5695    END DO
     5696    ! calcul de l entrainement total
     5697    DO ig = 1, ngrid
     5698      entr_star_tot(ig) = 0.
     5699    END DO
     5700    DO ig = 1, ngrid
     5701      DO k = 1, klev
     5702        entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k)
     5703      END DO
     5704    END DO
     5705    ! Calcul entrainement normalise
     5706    DO ig = 1, ngrid
     5707      IF (entr_star_tot(ig)>1.E-10) THEN
     5708        ! do l=1,lentr(ig)
     5709        DO l = 1, klev
     5710          ! def possibles pour entr_star: zdthetadz, dthetadz, zdtheta
     5711          entr_star(ig, l) = entr_star(ig, l) / entr_star_tot(ig)
     5712        END DO
     5713      END IF
     5714    END DO
     5715
     5716    ! PRINT*,'fin calcul entr_star'
     5717    DO k = 1, klev
     5718      DO ig = 1, ngrid
     5719        ztva(ig, k) = ztv(ig, k)
     5720      END DO
     5721    END DO
     5722    ! RC
     5723    ! PRINT*,'7 OK convect8'
     5724    DO k = 1, klev + 1
     5725      DO ig = 1, ngrid
     5726        zw2(ig, k) = 0.
     5727        fmc(ig, k) = 0.
     5728        ! CR
     5729        f_star(ig, k) = 0.
     5730        ! RC
     5731        larg_cons(ig, k) = 0.
     5732        larg_detr(ig, k) = 0.
     5733        wa_moy(ig, k) = 0.
     5734      END DO
     5735    END DO
     5736
     5737    ! PRINT*,'8 OK convect8'
     5738    DO ig = 1, ngrid
     5739      linter(ig) = 1.
     5740      lmaxa(ig) = 1
     5741      lmix(ig) = 1
     5742      wmaxa(ig) = 0.
     5743    END DO
     5744
     5745    ! CR:
     5746    DO l = 1, nlay - 2
     5747      DO ig = 1, ngrid
     5748        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. entr_star(ig, l)>1.E-10 .AND. &
     5749                zw2(ig, l)<1E-10) THEN
     5750          f_star(ig, l + 1) = entr_star(ig, l)
     5751          ! test:calcul de dteta
     5752          zw2(ig, l + 1) = 2. * rg * (ztv(ig, l) - ztv(ig, l + 1)) / ztv(ig, l + 1) * &
     5753                  (zlev(ig, l + 1) - zlev(ig, l)) * 0.4 * pphi(ig, l) / (pphi(ig, l + 1) - pphi(ig, l))
     5754          larg_detr(ig, l) = 0.
     5755        ELSE IF ((zw2(ig, l)>=1E-10) .AND. (f_star(ig, l) + entr_star(ig, &
     5756                l)>1.E-10)) THEN
     5757          f_star(ig, l + 1) = f_star(ig, l) + entr_star(ig, l)
     5758          ztva(ig, l) = (f_star(ig, l) * ztva(ig, l - 1) + entr_star(ig, l) * ztv(ig, l)) / &
     5759                  f_star(ig, l + 1)
     5760          zw2(ig, l + 1) = zw2(ig, l) * (f_star(ig, l) / f_star(ig, l + 1))**2 + &
     5761                  2. * rg * (ztva(ig, l) - ztv(ig, l)) / ztv(ig, l) * (zlev(ig, l + 1) - zlev(ig, l))
     5762        END IF
     5763        ! determination de zmax continu par interpolation lineaire
     5764        IF (zw2(ig, l + 1)<0.) THEN
     5765          ! test
     5766          IF (abs(zw2(ig, l + 1) - zw2(ig, l))<1E-10) THEN
     5767            ! PRINT*,'pb linter'
     5768          END IF
     5769          linter(ig) = (l * (zw2(ig, l + 1) - zw2(ig, l)) - zw2(ig, l)) / (zw2(ig, l + 1) - zw2(&
     5770                  ig, l))
     5771          zw2(ig, l + 1) = 0.
     5772          lmaxa(ig) = l
     5773        ELSE
     5774          IF (zw2(ig, l + 1)<0.) THEN
     5775            ! PRINT*,'pb1 zw2<0'
     5776          END IF
     5777          wa_moy(ig, l + 1) = sqrt(zw2(ig, l + 1))
     5778        END IF
     5779        IF (wa_moy(ig, l + 1)>wmaxa(ig)) THEN
     5780          ! lmix est le niveau de la couche ou w (wa_moy) est maximum
     5781          lmix(ig) = l + 1
     5782          wmaxa(ig) = wa_moy(ig, l + 1)
     5783        END IF
     5784      END DO
     5785    END DO
     5786    ! PRINT*,'fin calcul zw2'
     5787
     5788    ! Calcul de la couche correspondant a la hauteur du thermique
     5789    DO ig = 1, ngrid
     5790      lmax(ig) = lentr(ig)
     5791      ! lmax(ig)=lalim(ig)
     5792    END DO
     5793    DO ig = 1, ngrid
     5794      DO l = nlay, lentr(ig) + 1, -1
     5795        ! do l=nlay,lalim(ig)+1,-1
     5796        IF (zw2(ig, l)<=1.E-10) THEN
     5797          lmax(ig) = l - 1
     5798        END IF
     5799      END DO
     5800    END DO
     5801    ! pas de thermique si couche 1 stable
     5802    DO ig = 1, ngrid
     5803      IF (lmin(ig)>5) THEN
     5804        lmax(ig) = 1
     5805        lmin(ig) = 1
     5806        lentr(ig) = 1
     5807        lalim(ig) = 1
     5808      END IF
     5809    END DO
     5810
     5811    ! Determination de zw2 max
     5812    DO ig = 1, ngrid
     5813      wmax(ig) = 0.
     5814    END DO
     5815
     5816    DO l = 1, nlay
     5817      DO ig = 1, ngrid
     5818        IF (l<=lmax(ig)) THEN
     5819          IF (zw2(ig, l)<0.) THEN
     5820            ! PRINT*,'pb2 zw2<0'
     5821          END IF
     5822          zw2(ig, l) = sqrt(zw2(ig, l))
     5823          wmax(ig) = max(wmax(ig), zw2(ig, l))
     5824        ELSE
     5825          zw2(ig, l) = 0.
     5826        END IF
     5827      END DO
     5828    END DO
     5829
     5830    ! Longueur caracteristique correspondant a la hauteur des thermiques.
     5831    DO ig = 1, ngrid
     5832      zmax(ig) = 0.
     5833      zlevinter(ig) = zlev(ig, 1)
     5834    END DO
     5835    DO ig = 1, ngrid
     5836      ! calcul de zlevinter
     5837      zlevinter(ig) = (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig))) * linter(ig) + &
     5838              zlev(ig, lmax(ig)) - lmax(ig) * (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig)))
     5839      zmax(ig) = max(zmax(ig), zlevinter(ig) - zlev(ig, lmin(ig)))
     5840    END DO
     5841    DO ig = 1, ngrid
     5842      ! WRITE(8,*)zmax(ig),lmax(ig),lentr(ig),lmin(ig)
     5843    END DO
     5844    ! on stope après les calculs de zmax et wmax
     5845    RETURN
     5846
     5847    ! PRINT*,'avant fermeture'
     5848    ! Fermeture,determination de f
     5849    ! Attention! entrainement normalisé ou pas?
     5850    DO ig = 1, ngrid
     5851      entr_star2(ig) = 0.
     5852    END DO
     5853    DO ig = 1, ngrid
     5854      IF (entr_star_tot(ig)<1.E-10) THEN
     5855        f(ig) = 0.
     5856      ELSE
     5857        DO k = lmin(ig), lentr(ig)
     5858          ! do k=lmin(ig),lalim(ig)
     5859          entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2 / (rho(ig, k) * (&
     5860                  zlev(ig, k + 1) - zlev(ig, k)))
     5861        END DO
     5862        ! Nouvelle fermeture
     5863        f(ig) = wmax(ig) / (max(500., zmax(ig)) * r_aspect * entr_star2(ig))
     5864        ! s            *entr_star_tot(ig)
     5865        ! test
     5866        ! if (first) THEN
     5867        f(ig) = f(ig) + (f0(ig) - f(ig)) * exp(-ptimestep / zmax(ig) * wmax(ig))
     5868        ! END IF
     5869      END IF
     5870      f0(ig) = f(ig)
     5871      ! first=.TRUE.
     5872    END DO
     5873    ! PRINT*,'apres fermeture'
     5874    ! on stoppe après la fermeture
     5875    RETURN
     5876    ! Calcul de l'entrainement
     5877    DO k = 1, klev
     5878      DO ig = 1, ngrid
     5879        entr(ig, k) = f(ig) * entr_star(ig, k)
     5880      END DO
     5881    END DO
     5882    ! on stoppe après le calcul de entr
     5883    ! RETURN
     5884    ! CR:test pour entrainer moins que la masse
     5885    ! do ig=1,ngrid
     5886    ! do l=1,lentr(ig)
     5887    ! if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) THEN
     5888    ! entr(ig,l+1)=entr(ig,l+1)+entr(ig,l)
     5889    ! s                       -0.9*masse(ig,l)/ptimestep
     5890    ! entr(ig,l)=0.9*masse(ig,l)/ptimestep
     5891    ! END IF
     5892    ! enddo
     5893    ! enddo
     5894    ! CR: fin test
     5895    ! Calcul des flux
     5896    DO ig = 1, ngrid
     5897      DO l = 1, lmax(ig) - 1
     5898        fmc(ig, l + 1) = fmc(ig, l) + entr(ig, l)
     5899      END DO
     5900    END DO
     5901
     5902    ! RC
     5903
     5904
     5905    ! PRINT*,'9 OK convect8'
     5906    ! PRINT*,'WA1 ',wa_moy
     5907
     5908    ! determination de l'indice du debut de la mixed layer ou w decroit
     5909
     5910    ! calcul de la largeur de chaque ascendance dans le cas conservatif.
     5911    ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant
     5912    ! d'une couche est égale à la hauteur de la couche alimentante.
     5913    ! La vitesse maximale dans l'ascendance est aussi prise comme estimation
     5914    ! de la vitesse d'entrainement horizontal dans la couche alimentante.
     5915
     5916    DO l = 2, nlay
     5917      DO ig = 1, ngrid
     5918        IF (l<=lmaxa(ig)) THEN
     5919          zw = max(wa_moy(ig, l), 1.E-10)
     5920          larg_cons(ig, l) = zmax(ig) * r_aspect * fmc(ig, l) / (rhobarz(ig, l) * zw)
     5921        END IF
     5922      END DO
     5923    END DO
     5924
     5925    DO l = 2, nlay
     5926      DO ig = 1, ngrid
     5927        IF (l<=lmaxa(ig)) THEN
     5928          ! if (idetr.EQ.0) THEN
     5929          ! cette option est finalement en dur.
     5930          IF ((l_mix * zlev(ig, l))<0.) THEN
     5931            ! PRINT*,'pb l_mix*zlev<0'
     5932          END IF
     5933          ! CR: test: nouvelle def de lambda
     5934          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     5935          IF (zw2(ig, l)>1.E-10) THEN
     5936            larg_detr(ig, l) = sqrt((l_mix / zw2(ig, l)) * zlev(ig, l))
     5937          ELSE
     5938            larg_detr(ig, l) = sqrt(l_mix * zlev(ig, l))
     5939          END IF
     5940          ! RC
     5941          ! ELSE IF (idetr.EQ.1) THEN
     5942          ! larg_detr(ig,l)=larg_cons(ig,l)
     5943          ! s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
     5944          ! ELSE IF (idetr.EQ.2) THEN
     5945          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     5946          ! s            *sqrt(wa_moy(ig,l))
     5947          ! ELSE IF (idetr.EQ.4) THEN
     5948          ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
     5949          ! s            *wa_moy(ig,l)
     5950          ! END IF
     5951        END IF
     5952      END DO
     5953    END DO
     5954
     5955    ! PRINT*,'10 OK convect8'
     5956    ! PRINT*,'WA2 ',wa_moy
     5957    ! calcul de la fraction de la maille concernée par l'ascendance en tenant
     5958    ! compte de l'epluchage du thermique.
     5959
     5960    ! CR def de  zmix continu (profil parabolique des vitesses)
     5961    DO ig = 1, ngrid
     5962      IF (lmix(ig)>1.) THEN
     5963        ! test
     5964        IF (((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig))) - &
     5965                (zlev(ig, lmix(ig) + 1))) - (zw2(ig, lmix(ig)) - &
     5966                zw2(ig, lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1)) - &
     5967                (zlev(ig, lmix(ig)))))>1E-10) THEN
     5968
     5969          zmix(ig) = ((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig)) &
     5970                  )**2 - (zlev(ig, lmix(ig) + 1))**2) - (zw2(ig, lmix(ig)) - zw2(ig, &
     5971                  lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1))**2 - (zlev(ig, lmix(ig)))**2)) / &
     5972                  (2. * ((zw2(ig, lmix(ig) - 1) - zw2(ig, lmix(ig))) * ((zlev(ig, lmix(ig))) - &
     5973                          (zlev(ig, lmix(ig) + 1))) - (zw2(ig, lmix(ig)) - &
     5974                          zw2(ig, lmix(ig) + 1)) * ((zlev(ig, lmix(ig) - 1)) - (zlev(ig, lmix(ig))))))
     5975        ELSE
     5976          zmix(ig) = zlev(ig, lmix(ig))
     5977          ! PRINT*,'pb zmix'
     5978        END IF
     5979      ELSE
     5980        zmix(ig) = 0.
     5981      END IF
     5982      ! test
     5983      IF ((zmax(ig) - zmix(ig))<0.) THEN
     5984        zmix(ig) = 0.99 * zmax(ig)
     5985        ! PRINT*,'pb zmix>zmax'
     5986      END IF
     5987    END DO
     5988
     5989    ! calcul du nouveau lmix correspondant
     5990    DO ig = 1, ngrid
     5991      DO l = 1, klev
     5992        IF (zmix(ig)>=zlev(ig, l) .AND. zmix(ig)<zlev(ig, l + 1)) THEN
     5993          lmix(ig) = l
     5994        END IF
     5995      END DO
     5996    END DO
     5997
     5998    DO l = 2, nlay
     5999      DO ig = 1, ngrid
     6000        IF (larg_cons(ig, l)>1.) THEN
     6001          ! PRINT*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
     6002          fraca(ig, l) = (larg_cons(ig, l) - larg_detr(ig, l)) / (r_aspect * zmax(ig))
     6003          ! test
     6004          fraca(ig, l) = max(fraca(ig, l), 0.)
     6005          fraca(ig, l) = min(fraca(ig, l), 0.5)
     6006          fracd(ig, l) = 1. - fraca(ig, l)
     6007          fracc(ig, l) = larg_cons(ig, l) / (r_aspect * zmax(ig))
     6008        ELSE
     6009          ! wa_moy(ig,l)=0.
     6010          fraca(ig, l) = 0.
     6011          fracc(ig, l) = 0.
     6012          fracd(ig, l) = 1.
     6013        END IF
     6014      END DO
     6015    END DO
     6016    ! CR: calcul de fracazmix
     6017    DO ig = 1, ngrid
     6018      fracazmix(ig) = (fraca(ig, lmix(ig) + 1) - fraca(ig, lmix(ig))) / &
     6019              (zlev(ig, lmix(ig) + 1) - zlev(ig, lmix(ig))) * zmix(ig) + &
     6020              fraca(ig, lmix(ig)) - zlev(ig, lmix(ig)) * (fraca(ig, lmix(ig) + 1) - fraca(ig &
     6021              , lmix(ig))) / (zlev(ig, lmix(ig) + 1) - zlev(ig, lmix(ig)))
     6022    END DO
     6023
     6024    DO l = 2, nlay
     6025      DO ig = 1, ngrid
     6026        IF (larg_cons(ig, l)>1.) THEN
     6027          IF (l>lmix(ig)) THEN
     6028            ! test
     6029            IF (zmax(ig) - zmix(ig)<1.E-10) THEN
     6030              ! PRINT*,'pb xxx'
     6031              xxx(ig, l) = (lmaxa(ig) + 1. - l) / (lmaxa(ig) + 1. - lmix(ig))
     6032            ELSE
     6033              xxx(ig, l) = (zmax(ig) - zlev(ig, l)) / (zmax(ig) - zmix(ig))
     6034            END IF
     6035            IF (idetr==0) THEN
     6036              fraca(ig, l) = fracazmix(ig)
     6037            ELSE IF (idetr==1) THEN
     6038              fraca(ig, l) = fracazmix(ig) * xxx(ig, l)
     6039            ELSE IF (idetr==2) THEN
     6040              fraca(ig, l) = fracazmix(ig) * (1. - (1. - xxx(ig, l))**2)
     6041            ELSE
     6042              fraca(ig, l) = fracazmix(ig) * xxx(ig, l)**2
     6043            END IF
     6044            ! PRINT*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
     6045            fraca(ig, l) = max(fraca(ig, l), 0.)
     6046            fraca(ig, l) = min(fraca(ig, l), 0.5)
     6047            fracd(ig, l) = 1. - fraca(ig, l)
     6048            fracc(ig, l) = larg_cons(ig, l) / (r_aspect * zmax(ig))
     6049          END IF
     6050        END IF
     6051      END DO
     6052    END DO
     6053
     6054    ! PRINT*,'fin calcul fraca'
     6055    ! PRINT*,'11 OK convect8'
     6056    ! PRINT*,'Ea3 ',wa_moy
     6057    ! ------------------------------------------------------------------
     6058    ! Calcul de fracd, wd
     6059    ! somme wa - wd = 0
     6060    ! ------------------------------------------------------------------
     6061
     6062    DO ig = 1, ngrid
     6063      fm(ig, 1) = 0.
     6064      fm(ig, nlay + 1) = 0.
     6065    END DO
     6066
     6067    DO l = 2, nlay
     6068      DO ig = 1, ngrid
     6069        fm(ig, l) = fraca(ig, l) * wa_moy(ig, l) * rhobarz(ig, l)
     6070        ! CR:test
     6071        IF (entr(ig, l - 1)<1E-10 .AND. fm(ig, l)>fm(ig, l - 1) .AND. l>lmix(ig)) THEN
     6072          fm(ig, l) = fm(ig, l - 1)
     6073          ! WRITE(1,*)'ajustement fm, l',l
     6074        END IF
     6075        ! WRITE(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
     6076        ! RC
     6077      END DO
     6078      DO ig = 1, ngrid
     6079        IF (fracd(ig, l)<0.1) THEN
     6080          abort_message = 'fracd trop petit'
     6081          CALL abort_physic(modname, abort_message, 1)
     6082
     6083        ELSE
     6084          ! vitesse descendante "diagnostique"
     6085          wd(ig, l) = fm(ig, l) / (fracd(ig, l) * rhobarz(ig, l))
     6086        END IF
     6087      END DO
     6088    END DO
     6089
     6090    DO l = 1, nlay
     6091      DO ig = 1, ngrid
     6092        ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
     6093        masse(ig, l) = (pplev(ig, l) - pplev(ig, l + 1)) / rg
     6094      END DO
     6095    END DO
     6096
     6097    ! PRINT*,'12 OK convect8'
     6098    ! PRINT*,'WA4 ',wa_moy
     6099    ! c------------------------------------------------------------------
     6100    ! calcul du transport vertical
     6101    ! ------------------------------------------------------------------
     6102
     6103    GO TO 4444
     6104    ! PRINT*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
     6105    DO l = 2, nlay - 1
     6106      DO ig = 1, ngrid
     6107        IF (fm(ig, l + 1) * ptimestep>masse(ig, l) .AND. fm(ig, l + 1) * ptimestep>masse(&
     6108                ig, l + 1)) THEN
     6109          ! PRINT*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
     6110          ! s         ,fm(ig,l+1)*ptimestep
     6111          ! s         ,'   M=',masse(ig,l),masse(ig,l+1)
     6112        END IF
     6113      END DO
     6114    END DO
     6115
     6116    DO l = 1, nlay
     6117      DO ig = 1, ngrid
     6118        IF (entr(ig, l) * ptimestep>masse(ig, l)) THEN
     6119          ! PRINT*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
     6120          ! s         ,entr(ig,l)*ptimestep
     6121          ! s         ,'   M=',masse(ig,l)
     6122        END IF
     6123      END DO
     6124    END DO
     6125
     6126    DO l = 1, nlay
     6127      DO ig = 1, ngrid
     6128        IF (.NOT. fm(ig, l)>=0. .OR. .NOT. fm(ig, l)<=10.) THEN
     6129          ! PRINT*,'WARN!!! fm exagere ig=',ig,'   l=',l
     6130          ! s         ,'   FM=',fm(ig,l)
     6131        END IF
     6132        IF (.NOT. masse(ig, l)>=1.E-10 .OR. .NOT. masse(ig, l)<=1.E4) THEN
     6133          ! PRINT*,'WARN!!! masse exagere ig=',ig,'   l=',l
     6134          ! s         ,'   M=',masse(ig,l)
     6135          ! PRINT*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
     6136          ! s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
     6137          ! PRINT*,'zlev(ig,l+1),zlev(ig,l)'
     6138          ! s                ,zlev(ig,l+1),zlev(ig,l)
     6139          ! PRINT*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
     6140          ! s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
     6141        END IF
     6142        IF (.NOT. entr(ig, l)>=0. .OR. .NOT. entr(ig, l)<=10.) THEN
     6143          ! PRINT*,'WARN!!! entr exagere ig=',ig,'   l=',l
     6144          ! s         ,'   E=',entr(ig,l)
     6145        END IF
     6146      END DO
     6147    END DO
     6148
     6149    4444 CONTINUE
     6150
     6151    ! CR:redefinition du entr
     6152    DO l = 1, nlay
     6153      DO ig = 1, ngrid
     6154        detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l + 1)
     6155        IF (detr(ig, l)<0.) THEN
     6156          ! entr(ig,l)=entr(ig,l)-detr(ig,l)
     6157          fm(ig, l + 1) = fm(ig, l) + entr(ig, l)
     6158          detr(ig, l) = 0.
     6159          ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
     6160        END IF
     6161      END DO
     6162    END DO
     6163    ! RC
     6164    IF (w2di==1) THEN
     6165      fm0 = fm0 + ptimestep * (fm - fm0) / tho
     6166      entr0 = entr0 + ptimestep * (entr - entr0) / tho
     6167    ELSE
     6168      fm0 = fm
     6169      entr0 = entr
     6170    END IF
     6171
     6172    IF (1==1) THEN
     6173      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, &
     6174              zha)
     6175      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, &
     6176              zoa)
     6177    ELSE
     6178      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, &
     6179              zdhadj, zha)
     6180      CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, &
     6181              pdoadj, zoa)
     6182    END IF
     6183
     6184    IF (1==0) THEN
     6185      CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, &
     6186              zu, zv, pduadj, pdvadj, zua, zva)
     6187    ELSE
     6188      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, &
     6189              zua)
     6190      CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, &
     6191              zva)
     6192    END IF
     6193
     6194    DO l = 1, nlay
     6195      DO ig = 1, ngrid
     6196        zf = 0.5 * (fracc(ig, l) + fracc(ig, l + 1))
     6197        zf2 = zf / (1. - zf)
     6198        thetath2(ig, l) = zf2 * (zha(ig, l) - zh(ig, l))**2
     6199        wth2(ig, l) = zf2 * (0.5 * (wa_moy(ig, l) + wa_moy(ig, l + 1)))**2
     6200      END DO
     6201    END DO
     6202
     6203
     6204
     6205    ! PRINT*,'13 OK convect8'
     6206    ! PRINT*,'WA5 ',wa_moy
     6207    DO l = 1, nlay
     6208      DO ig = 1, ngrid
     6209        pdtadj(ig, l) = zdhadj(ig, l) * zpspsk(ig, l)
     6210      END DO
     6211    END DO
     6212
     6213
     6214    ! do l=1,nlay
     6215    ! do ig=1,ngrid
     6216    ! IF(abs(pdtadj(ig,l))*86400..gt.500.) THEN
     6217    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     6218    ! s         ,'   pdtadj=',pdtadj(ig,l)
     6219    ! END IF
     6220    ! IF(abs(pdoadj(ig,l))*86400..gt.1.) THEN
     6221    ! PRINT*,'WARN!!! ig=',ig,'  l=',l
     6222    ! s         ,'   pdoadj=',pdoadj(ig,l)
     6223    ! END IF
     6224    ! enddo
     6225    ! enddo
     6226
     6227    ! PRINT*,'14 OK convect8'
     6228    ! ------------------------------------------------------------------
     6229    ! Calculs pour les sorties
     6230    ! ------------------------------------------------------------------
     6231
     6232    IF (sorties) THEN
     6233      DO l = 1, nlay
     6234        DO ig = 1, ngrid
     6235          zla(ig, l) = (1. - fracd(ig, l)) * zmax(ig)
     6236          zld(ig, l) = fracd(ig, l) * zmax(ig)
     6237          IF (1. - fracd(ig, l)>1.E-10) zwa(ig, l) = wd(ig, l) * fracd(ig, l) / &
     6238                  (1. - fracd(ig, l))
     6239        END DO
     6240      END DO
     6241
     6242      ! deja fait
     6243      ! do l=1,nlay
     6244      ! do ig=1,ngrid
     6245      ! detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
     6246      ! if (detr(ig,l).lt.0.) THEN
     6247      ! entr(ig,l)=entr(ig,l)-detr(ig,l)
     6248      ! detr(ig,l)=0.
     6249      ! PRINT*,'WARNING !!! detrainement negatif ',ig,l
     6250      ! END IF
     6251      ! enddo
     6252      ! enddo
     6253
     6254      ! PRINT*,'15 OK convect8'
     6255
     6256      isplit = isplit + 1
     6257
     6258
     6259      ! #define und
     6260      GO TO 123
    62896261#ifdef und
    62906262    CALL writeg1d(1, nlay, wd, 'wd      ', 'wd      ')
    … …  
    63226294    CALL writeg1d(1, nlay, wh, 'wh2     ', 'wh2     ')
    63236295#endif
    6324 123 CONTINUE
    6325 
    6326   END IF
    6327 
    6328   ! IF(wa_moy(1,4).gt.1.e-10) stop
    6329 
    6330   ! PRINT*,'19 OK convect8'
    6331 
    6332 END SUBROUTINE calcul_sec
    6333 
    6334 SUBROUTINE fermeture_seche(ngrid, nlay, pplay, pplev, pphi, zlev, rhobarz, &
    6335     f0, zpspsk, alim_star, zh, zo, lentr, lmin, nu_min, nu_max, r_aspect, &
    6336     zmax, wmax)
    6337 
    6338   USE dimphy
    6339   IMPLICIT NONE
    6340 
    6341   include "YOMCST.h"
    6342 
    6343   INTEGER ngrid, nlay
    6344   REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1)
    6345   REAL pphi(ngrid, nlay)
    6346   REAL zlev(klon, klev+1)
    6347   REAL alim_star(klon, klev)
    6348   REAL f0(klon)
    6349   INTEGER lentr(klon)
    6350   INTEGER lmin(klon)
    6351   REAL zmax(klon)
    6352   REAL wmax(klon)
    6353   REAL nu_min
    6354   REAL nu_max
    6355   REAL r_aspect
    6356   REAL rhobarz(klon, klev+1)
    6357   REAL zh(klon, klev)
    6358   REAL zo(klon, klev)
    6359   REAL zpspsk(klon, klev)
    6360 
    6361   INTEGER ig, l
    6362 
    6363   REAL f_star(klon, klev+1)
    6364   REAL detr_star(klon, klev)
    6365   REAL entr_star(klon, klev)
    6366   REAL zw2(klon, klev+1)
    6367   REAL linter(klon)
    6368   INTEGER lmix(klon)
    6369   INTEGER lmax(klon)
    6370   REAL zlevinter(klon)
    6371   REAL wa_moy(klon, klev+1)
    6372   REAL wmaxa(klon)
    6373   REAL ztv(klon, klev)
    6374   REAL ztva(klon, klev)
    6375   REAL nu(klon, klev)
    6376   ! real zmax0_sec(klon)
    6377   ! save zmax0_sec
    6378   REAL, SAVE, ALLOCATABLE :: zmax0_sec(:)
    6379   !$OMP THREADPRIVATE(zmax0_sec)
    6380   LOGICAL, SAVE :: first = .TRUE.
    6381   !$OMP THREADPRIVATE(first)
    6382 
    6383   IF (first) THEN
    6384     ALLOCATE (zmax0_sec(klon))
    6385     first = .FALSE.
    6386   END IF
    6387 
    6388   DO l = 1, nlay
    6389     DO ig = 1, ngrid
    6390       ztv(ig, l) = zh(ig, l)/zpspsk(ig, l)
    6391       ztv(ig, l) = ztv(ig, l)*(1.+retv*zo(ig,l))
    6392     END DO
    6393   END DO
    6394   DO l = 1, nlay - 2
    6395     DO ig = 1, ngrid
    6396       IF (ztv(ig,l)>ztv(ig,l+1) .AND. alim_star(ig,l)>1.E-10 .AND. &
    6397           zw2(ig,l)<1E-10) THEN
    6398         f_star(ig, l+1) = alim_star(ig, l)
    6399         ! test:calcul de dteta
    6400         zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* &
    6401           (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l))
    6402       ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+alim_star(ig, &
    6403           l))>1.E-10) THEN
    6404         ! estimation du detrainement a partir de la geometrie du pas
    6405         ! precedent
    6406         ! tests sur la definition du detr
    6407         nu(ig, l) = (nu_min+nu_max)/2.*(1.-(nu_max-nu_min)/(nu_max+nu_min)* &
    6408           tanh((((ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l))/0.0005)))
    6409 
    6410         detr_star(ig, l) = rhobarz(ig, l)*sqrt(zw2(ig,l))/ &
    6411           (r_aspect*zmax0_sec(ig))* & ! s
    6412                                       ! /(r_aspect*zmax0(ig))*
    6413           (sqrt(nu(ig,l)*zlev(ig,l+1)/sqrt(zw2(ig,l)))-sqrt(nu(ig,l)*zlev(ig, &
    6414           l)/sqrt(zw2(ig,l))))
    6415         detr_star(ig, l) = detr_star(ig, l)/f0(ig)
    6416         IF ((detr_star(ig,l))>f_star(ig,l)) THEN
    6417           detr_star(ig, l) = f_star(ig, l)
    6418         END IF
    6419         entr_star(ig, l) = 0.9*detr_star(ig, l)
    6420         IF ((l<lentr(ig))) THEN
    6421           entr_star(ig, l) = 0.
    6422           ! detr_star(ig,l)=0.
    6423         END IF
    6424         ! PRINT*,'ok detr_star'
    6425         ! prise en compte du detrainement dans le calcul du flux
    6426         f_star(ig, l+1) = f_star(ig, l) + alim_star(ig, l) + &
    6427           entr_star(ig, l) - detr_star(ig, l)
    6428         ! test sur le signe de f_star
    6429         IF ((f_star(ig,l+1)+detr_star(ig,l))>1.E-10) THEN
    6430           ! AM on melange Tl et qt du thermique
    6431           ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+(entr_star(ig, &
    6432             l)+alim_star(ig,l))*ztv(ig,l))/(f_star(ig,l+1)+detr_star(ig,l))
    6433           zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/(f_star(ig, &
    6434             l+1)+detr_star(ig,l)))**2 + 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, &
    6435             l)*(zlev(ig,l+1)-zlev(ig,l))
    6436         END IF
     6296      123 CONTINUE
     6297
     6298    END IF
     6299
     6300    ! IF(wa_moy(1,4).gt.1.e-10) stop
     6301
     6302    ! PRINT*,'19 OK convect8'
     6303
     6304  END SUBROUTINE calcul_sec
     6305
     6306  SUBROUTINE fermeture_seche(ngrid, nlay, pplay, pplev, pphi, zlev, rhobarz, &
     6307          f0, zpspsk, alim_star, zh, zo, lentr, lmin, nu_min, nu_max, r_aspect, &
     6308          zmax, wmax)
     6309
     6310    USE dimphy
     6311    IMPLICIT NONE
     6312
     6313    include "YOMCST.h"
     6314
     6315    INTEGER ngrid, nlay
     6316    REAL pplay(ngrid, nlay), pplev(ngrid, nlay + 1)
     6317    REAL pphi(ngrid, nlay)
     6318    REAL zlev(klon, klev + 1)
     6319    REAL alim_star(klon, klev)
     6320    REAL f0(klon)
     6321    INTEGER lentr(klon)
     6322    INTEGER lmin(klon)
     6323    REAL zmax(klon)
     6324    REAL wmax(klon)
     6325    REAL nu_min
     6326    REAL nu_max
     6327    REAL r_aspect
     6328    REAL rhobarz(klon, klev + 1)
     6329    REAL zh(klon, klev)
     6330    REAL zo(klon, klev)
     6331    REAL zpspsk(klon, klev)
     6332
     6333    INTEGER ig, l
     6334
     6335    REAL f_star(klon, klev + 1)
     6336    REAL detr_star(klon, klev)
     6337    REAL entr_star(klon, klev)
     6338    REAL zw2(klon, klev + 1)
     6339    REAL linter(klon)
     6340    INTEGER lmix(klon)
     6341    INTEGER lmax(klon)
     6342    REAL zlevinter(klon)
     6343    REAL wa_moy(klon, klev + 1)
     6344    REAL wmaxa(klon)
     6345    REAL ztv(klon, klev)
     6346    REAL ztva(klon, klev)
     6347    REAL nu(klon, klev)
     6348    ! real zmax0_sec(klon)
     6349    ! save zmax0_sec
     6350    REAL, SAVE, ALLOCATABLE :: zmax0_sec(:)
     6351    !$OMP THREADPRIVATE(zmax0_sec)
     6352    LOGICAL, SAVE :: first = .TRUE.
     6353    !$OMP THREADPRIVATE(first)
     6354
     6355    IF (first) THEN
     6356      ALLOCATE (zmax0_sec(klon))
     6357      first = .FALSE.
     6358    END IF
     6359
     6360    DO l = 1, nlay
     6361      DO ig = 1, ngrid
     6362        ztv(ig, l) = zh(ig, l) / zpspsk(ig, l)
     6363        ztv(ig, l) = ztv(ig, l) * (1. + retv * zo(ig, l))
     6364      END DO
     6365    END DO
     6366    DO l = 1, nlay - 2
     6367      DO ig = 1, ngrid
     6368        IF (ztv(ig, l)>ztv(ig, l + 1) .AND. alim_star(ig, l)>1.E-10 .AND. &
     6369                zw2(ig, l)<1E-10) THEN
     6370          f_star(ig, l + 1) = alim_star(ig, l)
     6371          ! test:calcul de dteta
     6372          zw2(ig, l + 1) = 2. * rg * (ztv(ig, l) - ztv(ig, l + 1)) / ztv(ig, l + 1) * &
     6373                  (zlev(ig, l + 1) - zlev(ig, l)) * 0.4 * pphi(ig, l) / (pphi(ig, l + 1) - pphi(ig, l))
     6374        ELSE IF ((zw2(ig, l)>=1E-10) .AND. (f_star(ig, l) + alim_star(ig, &
     6375                l))>1.E-10) THEN
     6376          ! estimation du detrainement a partir de la geometrie du pas
     6377          ! precedent
     6378          ! tests sur la definition du detr
     6379          nu(ig, l) = (nu_min + nu_max) / 2. * (1. - (nu_max - nu_min) / (nu_max + nu_min) * &
     6380                  tanh((((ztva(ig, l - 1) - ztv(ig, l)) / ztv(ig, l)) / 0.0005)))
     6381
     6382          detr_star(ig, l) = rhobarz(ig, l) * sqrt(zw2(ig, l)) / &
     6383                  (r_aspect * zmax0_sec(ig)) * & ! s
     6384                  ! /(r_aspect*zmax0(ig))*
     6385                  (sqrt(nu(ig, l) * zlev(ig, l + 1) / sqrt(zw2(ig, l))) - sqrt(nu(ig, l) * zlev(ig, &
     6386                          l) / sqrt(zw2(ig, l))))
     6387          detr_star(ig, l) = detr_star(ig, l) / f0(ig)
     6388          IF ((detr_star(ig, l))>f_star(ig, l)) THEN
     6389            detr_star(ig, l) = f_star(ig, l)
     6390          END IF
     6391          entr_star(ig, l) = 0.9 * detr_star(ig, l)
     6392          IF ((l<lentr(ig))) THEN
     6393            entr_star(ig, l) = 0.
     6394            ! detr_star(ig,l)=0.
     6395          END IF
     6396          ! PRINT*,'ok detr_star'
     6397          ! prise en compte du detrainement dans le calcul du flux
     6398          f_star(ig, l + 1) = f_star(ig, l) + alim_star(ig, l) + &
     6399                  entr_star(ig, l) - detr_star(ig, l)
     6400          ! test sur le signe de f_star
     6401          IF ((f_star(ig, l + 1) + detr_star(ig, l))>1.E-10) THEN
     6402            ! AM on melange Tl et qt du thermique
     6403            ztva(ig, l) = (f_star(ig, l) * ztva(ig, l - 1) + (entr_star(ig, &
     6404                    l) + alim_star(ig, l)) * ztv(ig, l)) / (f_star(ig, l + 1) + detr_star(ig, l))
     6405            zw2(ig, l + 1) = zw2(ig, l) * (f_star(ig, l) / (f_star(ig, &
     6406                    l + 1) + detr_star(ig, l)))**2 + 2. * rg * (ztva(ig, l) - ztv(ig, l)) / ztv(ig, &
     6407                    l) * (zlev(ig, l + 1) - zlev(ig, l))
     6408          END IF
     6409        END IF
     6410
     6411        IF (zw2(ig, l + 1)<0.) THEN
     6412          linter(ig) = (l * (zw2(ig, l + 1) - zw2(ig, l)) - zw2(ig, l)) / (zw2(ig, l + 1) - zw2(&
     6413                  ig, l))
     6414          zw2(ig, l + 1) = 0.
     6415          ! PRINT*,'linter=',linter(ig)
     6416        ELSE
     6417          wa_moy(ig, l + 1) = sqrt(zw2(ig, l + 1))
     6418        END IF
     6419        IF (wa_moy(ig, l + 1)>wmaxa(ig)) THEN
     6420          ! lmix est le niveau de la couche ou w (wa_moy) est maximum
     6421          lmix(ig) = l + 1
     6422          wmaxa(ig) = wa_moy(ig, l + 1)
     6423        END IF
     6424      END DO
     6425    END DO
     6426    ! PRINT*,'fin calcul zw2'
     6427
     6428    ! Calcul de la couche correspondant a la hauteur du thermique
     6429    DO ig = 1, ngrid
     6430      lmax(ig) = lentr(ig)
     6431    END DO
     6432    DO ig = 1, ngrid
     6433      DO l = nlay, lentr(ig) + 1, -1
     6434        IF (zw2(ig, l)<=1.E-10) THEN
     6435          lmax(ig) = l - 1
     6436        END IF
     6437      END DO
     6438    END DO
     6439    ! pas de thermique si couche 1 stable
     6440    DO ig = 1, ngrid
     6441      IF (lmin(ig)>1) THEN
     6442        lmax(ig) = 1
     6443        lmin(ig) = 1
     6444        lentr(ig) = 1
    64376445      END IF
    6438 
    6439       IF (zw2(ig,l+1)<0.) THEN
    6440         linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( &
    6441           ig,l))
    6442         zw2(ig, l+1) = 0.
    6443         ! PRINT*,'linter=',linter(ig)
    6444       ELSE
    6445         wa_moy(ig, l+1) = sqrt(zw2(ig,l+1))
    6446       END IF
    6447       IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN
    6448         ! lmix est le niveau de la couche ou w (wa_moy) est maximum
    6449         lmix(ig) = l + 1
    6450         wmaxa(ig) = wa_moy(ig, l+1)
    6451       END IF
    6452     END DO
    6453   END DO
    6454   ! PRINT*,'fin calcul zw2'
    6455 
    6456   ! Calcul de la couche correspondant a la hauteur du thermique
    6457   DO ig = 1, ngrid
    6458     lmax(ig) = lentr(ig)
    6459   END DO
    6460   DO ig = 1, ngrid
    6461     DO l = nlay, lentr(ig) + 1, -1
    6462       IF (zw2(ig,l)<=1.E-10) THEN
    6463         lmax(ig) = l - 1
    6464       END IF
    6465     END DO
    6466   END DO
    6467   ! pas de thermique si couche 1 stable
    6468   DO ig = 1, ngrid
    6469     IF (lmin(ig)>1) THEN
    6470       lmax(ig) = 1
    6471       lmin(ig) = 1
    6472       lentr(ig) = 1
    6473     END IF
    6474   END DO
    6475 
    6476   ! Determination de zw2 max
    6477   DO ig = 1, ngrid
    6478     wmax(ig) = 0.
    6479   END DO
    6480 
    6481   DO l = 1, nlay
    6482     DO ig = 1, ngrid
    6483       IF (l<=lmax(ig)) THEN
    6484         IF (zw2(ig,l)<0.) THEN
    6485           ! PRINT*,'pb2 zw2<0'
    6486         END IF
    6487         zw2(ig, l) = sqrt(zw2(ig,l))
    6488         wmax(ig) = max(wmax(ig), zw2(ig,l))
    6489       ELSE
    6490         zw2(ig, l) = 0.
    6491       END IF
    6492     END DO
    6493   END DO
    6494 
    6495   ! Longueur caracteristique correspondant a la hauteur des thermiques.
    6496   DO ig = 1, ngrid
    6497     zmax(ig) = 0.
    6498     zlevinter(ig) = zlev(ig, 1)
    6499   END DO
    6500   DO ig = 1, ngrid
    6501     ! calcul de zlevinter
    6502     zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + &
    6503       zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
    6504     ! pour le cas ou on prend tjs lmin=1
    6505     ! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
    6506     zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,1))
    6507     zmax0_sec(ig) = zmax(ig)
    6508   END DO
    6509 
    6510 
    6511 END SUBROUTINE fermeture_seche
     6446    END DO
     6447
     6448    ! Determination de zw2 max
     6449    DO ig = 1, ngrid
     6450      wmax(ig) = 0.
     6451    END DO
     6452
     6453    DO l = 1, nlay
     6454      DO ig = 1, ngrid
     6455        IF (l<=lmax(ig)) THEN
     6456          IF (zw2(ig, l)<0.) THEN
     6457            ! PRINT*,'pb2 zw2<0'
     6458          END IF
     6459          zw2(ig, l) = sqrt(zw2(ig, l))
     6460          wmax(ig) = max(wmax(ig), zw2(ig, l))
     6461        ELSE
     6462          zw2(ig, l) = 0.
     6463        END IF
     6464      END DO
     6465    END DO
     6466
     6467    ! Longueur caracteristique correspondant a la hauteur des thermiques.
     6468    DO ig = 1, ngrid
     6469      zmax(ig) = 0.
     6470      zlevinter(ig) = zlev(ig, 1)
     6471    END DO
     6472    DO ig = 1, ngrid
     6473      ! calcul de zlevinter
     6474      zlevinter(ig) = (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig))) * linter(ig) + &
     6475              zlev(ig, lmax(ig)) - lmax(ig) * (zlev(ig, lmax(ig) + 1) - zlev(ig, lmax(ig)))
     6476      ! pour le cas ou on prend tjs lmin=1
     6477      ! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
     6478      zmax(ig) = max(zmax(ig), zlevinter(ig) - zlev(ig, 1))
     6479      zmax0_sec(ig) = zmax(ig)
     6480    END DO
     6481
     6482  END SUBROUTINE fermeture_seche
    65126483
    65136484END MODULE lmdz_thermcell_old

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

    r5117 r5119  
    431431    IF (prt_level>=20) PRINT*, 'coucou calcul detr 470: ig, l', ig, l
    432432    RETURN
    433   end
     433  END
    434434END MODULE lmdz_thermcell_plume

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

    r5117 r5119  
    10561056
    10571057    IF (prt_level>=20) PRINT*, 'coucou calcul detr 470: ig, l', ig, l
    1058   end
     1058  END
    10591059END MODULE lmdz_thermcell_plume_6A

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

    r5117 r5119  
    9696
    9797RETURN
    98 end
     98END
    9999END MODULE lmdz_thermcell_qsat

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

    r5098 r5119  
    3939  !$OMP THREADPRIVATE(/YOMCST/)
    4040
    41 end module lmdz_yomcst
     41END MODULE lmdz_yomcst

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

    r5117 r5119  
    66  PRIVATE o3_prod
    77
    8 contains
     8CONTAINS
    99
    1010  SUBROUTINE o3_chem(julien, gmtime, t_seri, zmasse, pdtphys, rlat, rlon, q)
    … …  
    169169  END FUNCTION o3_prod
    170170
    171 end module o3_chem_m
     171END MODULE o3_chem_m

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

    r5117 r5119  
    44  IMPLICIT NONE
    55
    6 contains
     6CONTAINS
    77
    88  function ozonecm(rlat, paprs,read_climoz, rjour)
    … …  
    9595  END function ozonecm
    9696
    97 end module ozonecm_m
     97END MODULE ozonecm_m

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

    r5117 r5119  
    1212  ! ascending order)
    1313
    14 contains
     14CONTAINS
    1515
    1616  SUBROUTINE press_coefoz
    … …  
    7272  END SUBROUTINE  press_coefoz
    7373
    74 end module press_coefoz_m
     74END MODULE press_coefoz_m

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

    r5117 r5119  
    241241      REAL(KIND=8), DIMENSION(4), parameter :: OCT = (/ -.326E-03, -.102E-05, .137E-02, -.535E-05 /)
    242242
    243  end module radiation_AR4_param
     243 END MODULE radiation_AR4_param

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

    r5117 r5119  
    55  IMPLICIT NONE
    66
    7 contains
     7CONTAINS
    88
    99  SUBROUTINE radlwsw(&
    … …  
    17101710  END SUBROUTINE radlwsw
    17111711
    1712 end module radlwsw_m
     1712END MODULE radlwsw_m

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

    r5117 r5119  
    99  public regr_lat_time_coefoz
    1010
    11 contains
     11CONTAINS
    1212
    1313  SUBROUTINE regr_lat_time_coefoz
    … …  
    324324    ! (convert from rad to degrees and sort in ascending order)
    325325
    326   contains
     326CONTAINS
    327327
    328328    SUBROUTINE handle_err_copy_att(att_name)
    … …  
    344344  END SUBROUTINE  prepare_out
    345345
    346 end module regr_lat_time_coefoz_m
     346END MODULE regr_lat_time_coefoz_m

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

    r5117 r5119  
    3232  !$omp threadprivate(c_Mob, a2, a4_mass, a6_mass, r_het_interm)
    3333
    34 contains
     34CONTAINS
    3535
    3636  SUBROUTINE alloc_coefoz
    … …  
    161161  END SUBROUTINE  regr_pr_comb_coefoz
    162162
    163 end module regr_pr_comb_coefoz_m
     163END MODULE regr_pr_comb_coefoz_m

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

    r5117 r5119  
    66  IMPLICIT NONE
    77
    8 contains
     8CONTAINS
    99
    1010  SUBROUTINE regr_pr_int(ncid, name, julien, plev, pplay, top_value, v3)
    … …  
    102102  END SUBROUTINE  regr_pr_int
    103103
    104 end module regr_pr_int_m
     104END MODULE regr_pr_int_m

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

    r5117 r5119  
    44  IMPLICIT NONE
    55
    6 contains
     6CONTAINS
    77
    88  SUBROUTINE regr_pr_o3(p3d, o3_mob_regr)
    … …  
    9898  END SUBROUTINE  regr_pr_o3
    9999
    100 end module regr_pr_o3_m
     100END MODULE regr_pr_o3_m

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

    r5117 r5119  
    1212  REAL, PARAMETER :: undef = 999.
    1313
    14 contains
     14CONTAINS
    1515
    1616  REAL function search_tropopause(P, T, alt, N) result(P_tropo)
    … …  
    10971097  END SUBROUTINE  test_bornes
    10981098
    1099 end module m_simu_airs
     1099END MODULE m_simu_airs
    11001100
    11011101

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

    r5117 r5119  
    890890  SUBROUTINE gr_fi_dyn(nfield, im, jm, pfi, pdyn)
    891891    ! Transfer a variable from 1D "physics" grid to 2D "dynamics" grid
     892    USE lmdz_ssum_scopy, ONLY: scopy
     893
    892894    IMPLICIT NONE
    893895
    … …  
    916918  SUBROUTINE gr_dyn_fi(nfield, im, jm, pdyn, pfi)
    917919    ! Transfer a variable from 2D "dynamics" grid to 1D "physics" grid
     920    USE lmdz_ssum_scopy, ONLY: scopy
    918921    IMPLICIT NONE
    919922
    … …  
    11001103    ! convert values from scalar points to U points on C-grid
    11011104    ! used to compute wind stress at U points
     1105    USE lmdz_ssum_scopy, ONLY: scopy
     1106
    11021107    IMPLICIT NONE
    11031108
Note: See TracChangeset for help on using the changeset viewer.